(module string mzscheme
(require
(lib "pregexp.ss")
(lib "string.ss")
(lib "string.ss" "srfi" "13")
(planet "aif.ss" ("schematics" "macro.plt" 1 0))
)
(provide
(all-defined)
)
(define (string-namecase str)
(let* ([ans (string-titlecase str)]
[do-correction
(lambda (correct! positions offset)
(if positions
(for-each
(lambda (pair)
(if pair
(let ([pos-to-correct (+ (cdr pair) offset)])
(correct! ans pos-to-correct (add1 pos-to-correct)))))
positions)))])
(do-correction string-upcase! (pregexp-match-positions "^Mac" ans) 0)
(do-correction string-upcase! (pregexp-match-positions " Mac" ans) 0)
(do-correction string-upcase! (pregexp-match-positions "^Mc" ans) 0)
(do-correction string-upcase! (pregexp-match-positions " Mc" ans) 0)
(do-correction string-upcase! (pregexp-match-positions "^O'" ans) 0)
(do-correction string-upcase! (pregexp-match-positions " O'" ans) 0)
(do-correction string-downcase! (pregexp-match-positions "^Von" ans) -3)
(do-correction string-downcase! (pregexp-match-positions " Von" ans) -3)
(do-correction string-downcase! (pregexp-match-positions "^Van" ans) -3)
(do-correction string-downcase! (pregexp-match-positions " Van" ans) -3)
(do-correction string-downcase! (pregexp-match-positions "^Der" ans) -3)
(do-correction string-downcase! (pregexp-match-positions " Der" ans) -3)
(do-correction string-downcase! (pregexp-match-positions "^Le" ans) -2)
(do-correction string-downcase! (pregexp-match-positions " Le" ans) -2)
ans))
(define (ensure-string str)
(if (bytes? str)
(bytes->string/utf-8 str)
str))
)