Actually, move the old-style define/contract to its own file in mzlib,

and change around mzlib/contract.ss appropriately.

svn: r11715

original commit: 0870c7ae1ddd58de472e2990f6b194686e61b083

collects/mzlib/contract.ss

@@ -15,6 +15,13 @@
 (require "private/contract-object.ss")
 (provide (all-from-out "private/contract-object.ss"))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; old-style define/contract
+;;
+
+(require "private/contract-define.ss")
+(provide (all-from-out "private/contract-define.ss"))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -22,7 +29,9 @@
 ;; except the arrow contracts
 ;;
 
-(require scheme/private/contract
+(require (except-in scheme/private/contract
+                    define/contract
+                    with-contract)
          scheme/private/contract-guts
          scheme/private/contract-ds
          scheme/private/contract-opt
@@ -34,14 +43,10 @@
              lazy-depth-to-look)
  
  (except-out (all-from-out scheme/private/contract)
-             old-define/contract
-             define/contract
-             with-contract
              check-between/c
              string-len/c
              check-unary-between/c)
- (rename-out [string-len/c string/len]
+ (rename-out [string-len/c string/len]))
-             [old-define/contract define/contract]))
 
 ;; from contract-guts.ss
 

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))]))
+
+
+