Missed a file.

svn: r12452

original commit: eca59f6b1d98b59301a68c56f902f571340a5a16

collects/mzlib/private/contract-define.ss

@@ -0,0 +1,70 @@
+#lang scheme/base
+
+(provide define/contract)
+
+(require (for-syntax scheme/base)
+         (only-in scheme/contract contract)
+         (for-syntax (prefix-in a: scheme/private/contract-helpers)))
+
+;; First, we have the old define/contract implementation, which
+;; is still used in mzlib/contract.
+
+(define-for-syntax (make-define/contract-transformer contract-id id)
+  (make-set!-transformer
+   (λ (stx)
+     (with-syntax ([neg-blame-str (a:build-src-loc-string stx)]
+                   [contract-id contract-id]
+                   [id id])
+       (syntax-case stx (set!)
+         [(set! id arg)
+          (raise-syntax-error 'define/contract
+                              "cannot set! a define/contract variable"
+                              stx
+                              (syntax id))]
+         [(f arg ...)
+          (syntax/loc stx
+            ((contract contract-id
+                       id
+                       (format "definition ~a" (syntax->datum (quote-syntax f)))
+                       neg-blame-str
+                       (quote-syntax f))
+             arg
+             ...))]
+         [ident
+          (identifier? (syntax ident))
+          (syntax/loc stx
+            (contract contract-id
+                      id
+                      (format "definition ~a" (syntax->datum (quote-syntax ident)))
+                      neg-blame-str
+                      (quote-syntax ident)))])))))
+
+;; (define/contract id contract expr)
+;; defines `id' with `contract'; initially binding
+;; it to the result of `expr'.  These variables may not be set!'d.
+(define-syntax (define/contract define-stx)
+  (syntax-case define-stx ()
+    [(_ name contract-expr expr)
+     (identifier? (syntax name))
+     (with-syntax ([contract-id
+                    (a:mangle-id define-stx
+                                 "define/contract-contract-id"
+                                 (syntax name))]
+                   [id (a:mangle-id define-stx
+                                    "define/contract-id"
+                                    (syntax name))])
+       (syntax/loc define-stx
+         (begin
+           (define contract-id contract-expr)
+           (define-syntax name
+             (make-define/contract-transformer (quote-syntax contract-id)
+                                                   (quote-syntax id)))
+           (define id (let ([name expr]) name))  ;; let for procedure naming
+           )))]
+    [(_ name contract-expr expr)
+     (raise-syntax-error 'define/contract "expected identifier in first position"
+                         define-stx
+                         (syntax name))]))
+
+
+