diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
index bf96a1caf5..a19188176a 100644
--- a/collects/mzlib/contract.ss
+++ b/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
diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl
index 65dbd92e98..3478296362 100644
--- a/collects/mzlib/scribblings/contract.scrbl
+++ b/collects/mzlib/scribblings/contract.scrbl
@@ -1,5 +1,7 @@
 #lang scribble/doc
 @(require "common.ss"
+          scheme/sandbox
+          scribble/eval
           scribble/struct
           (for-label mzlib/contract))
 
@@ -56,7 +58,6 @@ from @schememodname[scheme/contract]:
  contract-violation->string
  contract?
  define-contract-struct
- define/contract
  false/c
  flat-contract
  flat-contract-predicate
@@ -91,3 +92,42 @@ from @schememodname[scheme/contract]:
  vector/c
  vectorof]
 
+It also provides the old version of @scheme[define/contract]:
+
+@defform[(define/contract id contract-expr init-value-expr)]{
+
+Attaches the contract @scheme[contract-expr] to
+@scheme[init-value-expr] and binds that to @scheme[id].
+
+The @scheme[define/contract] form treats individual definitions as
+units of blame. The definition itself is responsible for positive
+(co-variant) positions of the contract and each reference to
+@scheme[id] (including those in the initial value expression) must
+meet the negative positions of the contract.
+
+Error messages with @scheme[define/contract] are not as clear as those
+provided by @scheme[provide/contract], because
+@scheme[define/contract] cannot detect the name of the definition
+where the reference to the defined variable occurs. Instead, it uses
+the source location of the reference to the variable as the name of
+that definition.
+
+@examples[#:eval (parameterize ([sandbox-output 'string]
+                                [sandbox-error-output 'string]
+                                [sandbox-eval-limits #f])
+                   (make-evaluator 'mzscheme))
+                 (require mzlib/contract)
+                 (define/contract f
+                   (-> number? number?)
+                   (lambda (x) (+ x 1)))
+                 (define/contract g
+                   (-> number? number?)
+                   (lambda (x) (f #t)))
+                 (define/contract i
+                   (-> number? number?)
+                   (lambda (x)
+                     (if (number? x) (i #t) 0)))
+                 (f 4)
+                 (f #t)
+                 (g 4)
+                 (i 3)]}
diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss
index 0fcf37a5df..525a24ce19 100644
--- a/collects/scheme/private/contract-arrow.ss
+++ b/collects/scheme/private/contract-arrow.ss
@@ -102,10 +102,9 @@ v4 todo:
   #:omit-define-syntaxes
   #:property proj-prop
   (λ (ctc) 
-    (let* ([doms-proj (map (λ (x) ((proj-get x) x)) 
-                           (if (->-dom-rest/c ctc)
-                               (append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
-                               (->-doms/c ctc)))]
+    (let* ([doms-proj (map (λ (x) ((proj-get x) x)) (->-doms/c ctc))]
+           [rest-proj (and (->-dom-rest/c ctc)
+                           ((λ (x) ((proj-get x) x)) (->-dom-rest/c ctc)))]
            [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
            [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
            [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
@@ -117,22 +116,36 @@ v4 todo:
            [optionals-length (length (->-optional-doms/c ctc))]
            [has-rest? (and (->-dom-rest/c ctc) #t)])
       (λ (pos-blame neg-blame src-info orig-str)
-        (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
-                                 doms-proj)]
-              [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
-                                          doms-optional-proj)]
-              [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
-                                   rngs-proj)]
-              [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
-                                           mandatory-kwds-proj)]
-              [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
-                                          optional-kwds-proj)])
+        (let ([partial-doms (for/list ([dom (in-list doms-proj)]
+                                       [n   (in-naturals 1)])
+                              (dom neg-blame pos-blame src-info
+				   (cons (format "required argument ~a" n) orig-str)))]
+              [partial-rest (if rest-proj
+                                (list (rest-proj neg-blame pos-blame src-info
+                                                 (cons "rest argument" orig-str)))
+                                null)]
+              [partial-optional-doms (for/list ([dom (in-list doms-optional-proj)]
+                                                [n   (in-naturals 1)])
+                                         (dom neg-blame pos-blame src-info
+                                              (cons (format "optional argument ~a" n) orig-str)))]
+              [partial-ranges (for/list ([rng (in-list rngs-proj)]
+                                         [n   (in-naturals 1)])
+                                  (rng pos-blame neg-blame src-info
+                                       (cons (format "result ~a" n) orig-str)))]
+              [partial-mandatory-kwds (for/list ([kwd     (in-list mandatory-kwds-proj)]
+                                                 [kwd-lit (in-list mandatory-keywords)])
+                                        (kwd neg-blame pos-blame src-info
+                                             (cons (format "keyword argument ~a" kwd-lit) orig-str)))]
+              [partial-optional-kwds (for/list ([kwd     (in-list optional-kwds-proj)]
+                                                [kwd-lit (in-list optional-keywords)])
+                                       (kwd neg-blame pos-blame src-info
+                                            (cons (format "keyword argument ~a" kwd-lit) orig-str)))])
           (apply func
                  (λ (val mtd?)
                    (if has-rest?
                        (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
                        (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
-                 (append partial-doms partial-optional-doms 
+                 (append partial-doms partial-rest partial-optional-doms 
                          partial-mandatory-kwds partial-optional-kwds
                          partial-ranges))))))
   
diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss
index 6627e2dee7..185e87eac7 100644
--- a/collects/scheme/private/contract-guts.ss
+++ b/collects/scheme/private/contract-guts.ss
@@ -1,7 +1,8 @@
 #lang scheme/base
 
 (require "contract-helpers.ss"
-         scheme/pretty)
+         scheme/pretty
+         (only-in scheme/list add-between))
 
 (require (for-syntax scheme/base
                      "contract-helpers.ss"))
@@ -175,23 +176,35 @@
      (lambda (x) (get x 0))
      (lambda (x) (get x 1)))))
 
-(define (default-contract-violation->string val src-info to-blame contract-sexp msg)
+(define (default-contract-violation->string val src-info to-blame contract-sexp+extra msg)
+  (define (add-modifiers-to-contract modifiers contract-str)
+    (if (null? modifiers)
+        contract-str
+        (string-append "for " 
+                       (apply string-append (add-between modifiers " of "))
+                       " in " contract-str)))
   (let ([blame-src (src-info-as-string src-info)]
         [formatted-contract-sexp
-         (let ([one-line 
-                (let ([sp (open-output-string)])
-                  (parameterize ([pretty-print-print-line print-contract-liner]
-                                 [pretty-print-columns 'infinity])
-                    (pretty-print contract-sexp sp)
-                    (get-output-string sp)))])
-           (if (< (string-length one-line) 30)
-               one-line
-               (let ([sp (open-output-string)])
-                 (newline sp)
-                 (parameterize ([pretty-print-print-line print-contract-liner]
-                                [pretty-print-columns 50])
-                   (pretty-print contract-sexp sp))
-                 (get-output-string sp))))]
+         (let-values ([(modifiers contract-sexp)
+                       (let loop ([dlist contract-sexp+extra]
+                                  [modifiers null])
+                         (if (and (pair? dlist)
+                                  (string? (car dlist)))
+                             (loop (cdr dlist) (cons (car dlist) modifiers))
+                             (values (reverse modifiers) dlist)))])
+           (let ([one-line 
+                  (let ([sp (open-output-string)])
+                    (parameterize ([pretty-print-columns 'infinity])
+                      (pretty-print contract-sexp sp)
+                      (get-output-string sp)))])
+             (if (< (string-length one-line) 30)
+                 (add-modifiers-to-contract modifiers one-line)
+                 (let ([sp (open-output-string)])
+                   (newline sp)
+                   (parameterize ([pretty-print-print-line print-contract-liner]
+                                  [pretty-print-columns 50])
+                     (pretty-print contract-sexp sp))
+                   (add-modifiers-to-contract modifiers (get-output-string sp))))))]
         [specific-blame
          (cond
            [(syntax? src-info)
@@ -210,8 +223,9 @@
                                    (pair? (cdr to-blame))
                                    (null? (cddr to-blame))
                                    (equal? 'quote (car to-blame)))
-                              (format "'~s" (cadr to-blame))]
-                             [else (format "~s" to-blame)])
+                              (format "module '~s" (cadr to-blame))]
+                             [(string? to-blame) to-blame]
+                             [else (format "module ~s" to-blame)])
                            formatted-contract-sexp
                            specific-blame)
                    msg)))
@@ -516,4 +530,4 @@
   #:property name-prop (λ (ctc) (predicate-contract-name ctc))
   #:property flat-prop (λ (ctc) (predicate-contract-pred ctc)))
 
-(define (build-flat-contract name pred) (make-predicate-contract name pred))
\ No newline at end of file
+(define (build-flat-contract name pred) (make-predicate-contract name pred))
diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index c8d3d878b8..cee8b900cf 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -12,13 +12,19 @@ improve method arity mismatch contract violation error messages?
 (provide (rename-out [-contract contract])
          recursive-contract
          provide/contract
-         define/contract)
+         define/contract
+         with-contract
+         current-contract-region)
 
 (require (for-syntax scheme/base)
          (for-syntax "contract-opt-guts.ss")
          (for-syntax scheme/struct-info)
          (for-syntax scheme/list)
-         scheme/promise)
+         (for-syntax syntax/define)
+         (for-syntax syntax/kerncase)
+         scheme/promise
+         scheme/stxparam
+         mzlib/etc)
 
 (require "contract-arrow.ss"
          "contract-guts.ss"
@@ -28,6 +34,24 @@ improve method arity mismatch contract violation error messages?
          (for-syntax (prefix-in a: "contract-helpers.ss")))
 
 
+;; These are useful for all below.
+
+(define-syntax (verify-contract stx)
+  (syntax-case stx ()
+    [(_ name x) (a:known-good-contract? #'x) #'x]
+    [(_ name x) #'(coerce-contract name x)]))
+
+;; id->contract-src-info : identifier -> syntax
+;; constructs the last argument to the -contract, given an identifier
+(define-for-syntax (id->contract-src-info id)
+  #`(list (make-srcloc #,id
+                       #,(syntax-line id)
+                       #,(syntax-column id)
+                       #,(syntax-position id)
+                       #,(syntax-span id))
+          #,(format "~s" (syntax->datum id))))
+
+
 
 ;                                                                                                    
 ;                                                                                                    
@@ -46,6 +70,255 @@ improve method arity mismatch contract violation error messages?
 ;                                          ;                                                         
 ;                                                                                                    
 
+;; (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)
+  (when (eq? (syntax-local-context) 'expression)
+    (raise-syntax-error 'define/contract
+                        "used in expression context"
+                        define-stx))
+  (syntax-case define-stx ()
+    [(_ name)
+     (raise-syntax-error 'define/contract
+                         "no contract or body"
+                         define-stx)]
+    [(_ name contract-expr)
+     (raise-syntax-error 'define/contract
+                         "no body after contract"
+                         define-stx)]
+    [(_ name contract-expr expr)
+     (identifier? #'name)
+     (let ([contract (if (a:known-good-contract? #'contract-expr)
+                         #'contract-expr
+                         #'(verify-contract 'define/contract contract-expr))])
+       (quasisyntax/loc define-stx
+         (with-contract #:type definition name
+           ([name #,contract])
+           (define name expr))))]
+    [(_ name contract-expr expr0 expr ...)
+     (identifier? #'name)
+     (raise-syntax-error 'define/contract
+                         "multiple expressions after identifier and contract"
+                         define-stx)]
+    [(_ name+arg-list contract body0 body ...)
+     (let-values ([(name lam-expr)
+                   (normalize-definition
+                    (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list
+                                                       #'body0 #'(body ...)))
+                    #'lambda #t #t)])
+       (with-syntax ([name name]
+                     [lam-expr lam-expr])
+         (syntax/loc define-stx
+           (with-contract #:type function name
+             ([name (verify-contract 'define/contract contract)])
+             (define name lam-expr)))))]))
+
+
+
+;                                                                                         
+;                                                                                         
+;              ;       ;                                                                  
+;                  ;   ;                                     ;                         ;  
+;                  ;   ;                                     ;                         ;  
+;  ;    ;    ; ;  ;;;; ; ;;;          ;;;     ;;;    ; ;;;  ;;;; ; ;;   ;;;;     ;;;  ;;;;
+;  ;    ;    ; ;   ;   ;;   ;        ;   ;   ;   ;   ;;   ;  ;   ;;    ;    ;   ;   ;  ;  
+;   ;  ; ;  ;  ;   ;   ;    ;       ;       ;     ;  ;    ;  ;   ;    ;     ;  ;       ;  
+;   ;  ; ;  ;  ;   ;   ;    ;       ;       ;     ;  ;    ;  ;   ;        ;;;  ;       ;  
+;   ; ;   ; ;  ;   ;   ;    ;       ;       ;     ;  ;    ;  ;   ;     ;;;  ;  ;       ;  
+;   ; ;   ; ;  ;   ;   ;    ; ;;;;  ;       ;     ;  ;    ;  ;   ;    ;     ;  ;       ;  
+;   ; ;   ; ;  ;   ;   ;    ;       ;       ;     ;  ;    ;  ;   ;    ;     ;  ;       ;  
+;    ;     ;   ;   ;   ;    ;        ;   ;   ;   ;   ;    ;  ;   ;    ;    ;;   ;   ;  ;  
+;    ;     ;   ;   ;;; ;    ;         ;;;     ;;;    ;    ;  ;;; ;     ;;;; ;    ;;;   ;;;
+;                                                                                         
+;                                                                                         
+;                                                                                         
+
+(define-syntax-parameter current-contract-region #f)
+
+(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
+  (make-set!-transformer
+   (lambda (stx)
+     (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
+                                     #'(#%variable-reference))]
+                   [pos-blame-id pos-blame-id]
+                   [contract-id contract-id]
+                   [id id])
+       (syntax-case stx (set!)
+         [(set! id arg)
+          (raise-syntax-error 'with-contract
+                              "cannot set! a with-contract variable"
+                              stx
+                              (syntax id))]
+         [(f arg ...)
+          (syntax/loc stx
+            ((-contract contract-id
+                        id
+                        pos-blame-id
+                        neg-blame-id
+                        #'f)
+             arg ...))]
+         [ident
+          (identifier? (syntax ident))
+          (syntax/loc stx
+            (-contract contract-id
+                       id
+                       pos-blame-id
+                       neg-blame-id
+                       #'ident))])))))
+
+(define-for-syntax (head-expand-all body-stxs)
+  (for/list ([stx body-stxs])
+    (local-expand stx
+                  (syntax-local-context)
+                  (kernel-form-identifier-list))))
+
+(define-for-syntax (check-exports ids body-stxs)
+  (let ([defd-ids (for/fold ([id-list null])
+                            ([stx body-stxs])
+                    (kernel-syntax-case stx #f
+                      [(define-values ids expr)
+                       (append (syntax->list #'ids)
+                               id-list)]
+                      [_ id-list]))])
+    (for ([id (in-list ids)])
+         (unless (findf (lambda (s)
+                          (bound-identifier=? s id))
+                        defd-ids)
+           (raise-syntax-error 'with-contract
+                               "identifier not defined in body"
+                               id)))))
+
+(define-for-syntax (check-and-split-with-contract-args args)
+  (let loop ([args args]
+             [unprotected null]
+             [protected null]
+             [protections null])
+    (cond
+      [(null? args)
+       (values unprotected protected protections)]
+      [(identifier? (car args))
+       (loop (cdr args)
+             (cons (car args) unprotected)
+             protected
+             protections)]
+      [(let ([lst (syntax->list (car args))])
+         (and (list? lst)
+              (= (length lst) 2)
+              (identifier? (first lst))
+              lst))
+       =>
+       (lambda (l)
+         (loop (cdr args)
+               unprotected
+               (cons (first l) protected)
+               (cons (second l) protections)))]
+      [else
+       (raise-syntax-error 'with-contract
+                           "expected an identifier or (identifier contract)"
+                           (car args))])))
+
+(define-syntax (with-contract stx)
+  (when (eq? (syntax-local-context) 'expression)
+    (raise-syntax-error 'with-contract
+                        "used in expression context"
+                        stx))
+  (syntax-case stx ()
+    [(_ #:type type blame (arg ...) body0 body ...)
+     (and (identifier? #'blame)
+          (identifier? #'type))
+     (let*-values ([(unprotected protected protections)
+                    (check-and-split-with-contract-args (syntax->list #'(arg ...)))]
+                   [(expanded-bodies) (head-expand-all (cons #'body0
+                                                             (syntax->list #'(body ...))))]
+                   [(protected-ids ids contracts contract-defs)
+                    (for/lists (protected-ids ids contracts contract-defs)
+                      ([n protected]
+                       [c protections])
+                      (let ([new-id (a:mangle-id stx "with-contract-id" n)])
+                        (if (a:known-good-contract? c)
+                            (values n new-id c #f)
+                            (let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)])
+                              (values n new-id contract-id
+                                      (quasisyntax/loc stx
+                                        (define-values (#,contract-id)
+                                          (verify-contract 'with-contract #,c))))))))])
+       (begin
+         (let* ([all-ids (append unprotected protected)]
+                [dupd-id (check-duplicate-identifier all-ids)])
+           (when dupd-id
+             (raise-syntax-error 'with-contract
+                                 "identifier appears twice in exports"
+                                 dupd-id))
+           (check-exports (append unprotected protected) expanded-bodies))
+         (with-syntax ([((protected-id id contract) ...)
+                        (map list protected-ids ids contracts)]
+                       [(contract-def ...) (filter values contract-defs)]
+                       [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))]
+                       [(unprotected-id ...) unprotected])
+           (quasisyntax/loc stx
+             (begin 
+               (define-values (unprotected-id ... id ...)
+                 (syntax-parameterize ([current-contract-region blame-str])
+                   (begin-with-definitions
+                     #,@expanded-bodies
+                     (values unprotected-id ... protected-id ...))))
+               contract-def ...
+               (define-syntax protected-id
+                 (make-with-contract-transformer 
+                  (quote-syntax contract)
+                  (quote-syntax id)
+                  blame-str)) ...)))))]
+    [(_ #:type type blame (arg ...) body0 body ...)
+     (raise-syntax-error 'with-contract
+                         "expected identifier for blame"
+                         #'blame)]
+    [(_ #:type type blame (arg ...))
+     (identifier? #'blame)
+     (raise-syntax-error 'with-contract
+                         "empty body"
+                         stx)]
+    [(_ #:type type blame bad-args etc ...)
+     (identifier? #'blame)
+     (raise-syntax-error 'with-contract
+                         "expected list of identifier and/or (identifier contract)"
+                         #'bad-args)]
+    [(_ #:type type args etc ...)
+     (not (identifier? #'args))
+     (raise-syntax-error 'with-contract
+                         "expected identifier for blame"
+                         #'args)]
+    [(_ #:type type etc ...)
+     (not (identifier? #'type))
+     (raise-syntax-error 'with-contract
+                         "expected identifier for type"
+                         #'type)]
+    [(_ #:type type blame)
+     (raise-syntax-error 'with-contract
+                         "only blame"
+                         stx)]
+    [(_ etc ...)
+     (syntax/loc stx
+       (with-contract #:type region etc ...))]))
+
+;                                                                                                            
+;                                                                                                            
+;                                                                                                            
+;                               ;       ;             ;                                                      
+;                                       ;             ;                                                      
+;                                       ;            ;                           ;                       ;   
+;   ; ;;    ; ;   ;;;   ;     ; ;    ;; ;    ;;;     ;     ;;;    ;;;    ; ;;   ;;;;  ; ;  ;;;     ;;;  ;;;; 
+;   ;;  ;   ;;   ;   ;   ;   ;  ;   ;  ;;   ;   ;    ;    ;   ;  ;   ;   ;;  ;   ;    ;;  ;   ;   ;   ;  ;   
+;   ;    ;  ;   ;     ;  ;   ;  ;  ;    ;  ;    ;    ;   ;      ;     ;  ;   ;   ;    ;       ;  ;       ;   
+;   ;    ;  ;   ;     ;   ; ;   ;  ;    ;  ;;;;;;   ;    ;      ;     ;  ;   ;   ;    ;    ;;;;  ;       ;   
+;   ;    ;  ;   ;     ;   ; ;   ;  ;    ;  ;        ;    ;      ;     ;  ;   ;   ;    ;   ;   ;  ;       ;   
+;   ;;  ;   ;    ;   ;     ;    ;   ;  ;;   ;       ;     ;   ;  ;   ;   ;   ;   ;    ;   ;   ;   ;   ;  ;   
+;   ; ;;    ;     ;;;      ;    ;    ;; ;    ;;;;  ;       ;;;    ;;;    ;   ;    ;;  ;    ;;;;;   ;;;    ;; 
+;   ;                                              ;                                                         
+;   ;                                              ;                                                         
+;   ;                                                                                                        
+
+
 ;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
 (define-for-syntax (lookup-struct-info stx provide-stx)
   (let ([id (syntax-case stx ()
@@ -59,46 +332,6 @@ improve method arity mismatch contract violation error messages?
                               provide-stx
                               id)))))
 
-(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
-                        (syntax->datum (quote-syntax f))
-                        neg-blame-str
-                        (quote-syntax f))
-             arg
-             ...))]
-         [ident
-          (identifier? (syntax ident))
-          (syntax/loc stx
-            (-contract contract-id
-                       id
-                       (syntax->datum (quote-syntax ident)) 
-                       neg-blame-str
-                       (quote-syntax ident)))])))))
-
-;; id->contract-src-info : identifier -> syntax
-;; constructs the last argument to the -contract, given an identifier
-(define-for-syntax (id->contract-src-info id)
-  #`(list (make-srcloc #,id
-                       #,(syntax-line id)
-                       #,(syntax-column id)
-                       #,(syntax-position id)
-                       #,(syntax-span id))
-          #,(format "~s" (syntax->datum id))))
-
 (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
   (make-set!-transformer
    (let ([saved-id-table (make-hasheq)])
@@ -140,51 +373,6 @@ improve method arity mismatch contract violation error messages?
            ;; delay expansion until it's a good time to lift expressions:
            (quasisyntax/loc stx (#%expression #,stx)))))))
 
-;; (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))])) 
-
-
-;                                                                                                            
-;                                                                                                            
-;                                                                                                            
-;                               ;       ;             ;                                                      
-;                                       ;             ;                                                      
-;                                       ;            ;                           ;                       ;   
-;   ; ;;    ; ;   ;;;   ;     ; ;    ;; ;    ;;;     ;     ;;;    ;;;    ; ;;   ;;;;  ; ;  ;;;     ;;;  ;;;; 
-;   ;;  ;   ;;   ;   ;   ;   ;  ;   ;  ;;   ;   ;    ;    ;   ;  ;   ;   ;;  ;   ;    ;;  ;   ;   ;   ;  ;   
-;   ;    ;  ;   ;     ;  ;   ;  ;  ;    ;  ;    ;    ;   ;      ;     ;  ;   ;   ;    ;       ;  ;       ;   
-;   ;    ;  ;   ;     ;   ; ;   ;  ;    ;  ;;;;;;   ;    ;      ;     ;  ;   ;   ;    ;    ;;;;  ;       ;   
-;   ;    ;  ;   ;     ;   ; ;   ;  ;    ;  ;        ;    ;      ;     ;  ;   ;   ;    ;   ;   ;  ;       ;   
-;   ;;  ;   ;    ;   ;     ;    ;   ;  ;;   ;       ;     ;   ;  ;   ;   ;   ;   ;    ;   ;   ;   ;   ;  ;   
-;   ; ;;    ;     ;;;      ;    ;    ;; ;    ;;;;  ;       ;;;    ;;;    ;   ;    ;;  ;    ;;;;;   ;;;    ;; 
-;   ;                                              ;                                                         
-;   ;                                              ;                                                         
-;   ;                                                                                                        
-
 
 ;; (provide/contract p/c-ele ...)
 ;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...)
@@ -483,7 +671,7 @@ improve method arity mismatch contract violation error messages?
                                                     #f
                                                     (with-syntax ([field-contract-id field-contract-id]
                                                                   [field-contract field-contract])
-                                                      #'(define field-contract-id (verify-contract field-contract)))))
+                                                      #'(define field-contract-id (verify-contract 'provide/contract field-contract)))))
                                               field-contract-ids
                                               field-contracts))]
                          [(field-contracts ...) field-contracts]
@@ -671,7 +859,7 @@ improve method arity mismatch contract violation error messages?
                                    
                                    #,@(if no-need-to-check-ctrct?
                                           (list)
-                                          (list #'(define contract-id (verify-contract ctrct))))
+                                          (list #'(define contract-id (verify-contract 'provide/contract ctrct))))
                                    (define-syntax id-rename
                                      (make-provide/contract-transformer (quote-syntax contract-id)
                                                                         (quote-syntax id)
@@ -691,11 +879,6 @@ improve method arity mismatch contract violation error messages?
           (begin
             bodies ...))))]))
 
-(define-syntax (verify-contract stx)
-  (syntax-case stx ()
-    [(_ x) (a:known-good-contract? #'x) #'x]
-    [(_ x) #'(coerce-contract 'provide/contract x)]))
-
 (define (make-pc-struct-type struct-name struct:struct-name . ctcs)
   (let-values ([(struct:struct-name _make _pred _get _set)
                 (make-struct-type struct-name
diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss
index 4d0b8c923d..47e25f73d8 100644
--- a/collects/tests/mzscheme/contract-mzlib-test.ss
+++ b/collects/tests/mzscheme/contract-mzlib-test.ss
@@ -81,7 +81,7 @@ of the contract library does not change over time.
         (equal?
          blame
          (cond
-           [(regexp-match #rx"(^| )([^ ]*) broke" msg) 
+           [(regexp-match #rx"(^| )(.*) broke" msg) 
             =>
             (λ (x) (caddr x))]
            [else (format "no blame in error message: \"~a\"" msg)])))
@@ -103,8 +103,8 @@ of the contract library does not change over time.
                (and (exn? exn)
                     (,has-proper-blame? (exn-message exn))))))))))
   
-  (define (test/pos-blame name expression) (test/spec-failed name expression "pos"))
-  (define (test/neg-blame name expression) (test/spec-failed name expression "neg"))
+  (define (test/pos-blame name expression) (test/spec-failed name expression "module pos"))
+  (define (test/neg-blame name expression) (test/spec-failed name expression "module neg"))
   
   (define (test/well-formed stx)
     (contract-eval
@@ -126,7 +126,7 @@ of the contract library does not change over time.
         (contract-eval `(,test #t flat-contract? ,contract))
         (test/spec-failed (format "~a fail" name)
                           `(contract ,contract ',fail 'pos 'neg)
-                          "pos")
+                          "module pos")
         (test/spec-passed/result
          (format "~a pass" name)
          `(contract ,contract ',pass 'pos 'neg)
@@ -1577,14 +1577,14 @@ of the contract library does not change over time.
    '(let ()
       (define/contract i integer? #t)
       i)
-   "i")
+   "definition i")
   
   (test/spec-failed
    'define/contract3
    '(let ()
       (define/contract i (-> integer? integer?) (lambda (x) #t))
       (i 1))
-   "i")
+   "definition i")
   
   (test/spec-failed
    'define/contract4
@@ -4643,7 +4643,7 @@ so that propagation occurs.
                (provide/contract (x integer?))))
       (eval '(require 'contract-test-suite3))
       (eval 'x))
-   "'contract-test-suite3")
+   "module 'contract-test-suite3")
   
   (test/spec-passed
    'provide/contract4
@@ -4820,7 +4820,7 @@ so that propagation occurs.
                             (make-s 1 2)
                             [s-a #f])))
       (eval '(require 'pc11b-n)))
-   'n)
+   "module 'n")
 |#
   
   (test/spec-passed
@@ -4888,7 +4888,7 @@ so that propagation occurs.
                (define i #f)
                (provide/contract [i integer?])))
       (eval '(require 'pos)))
-   "'pos")
+   "module 'pos")
   
   ;; this is really a positive violation, but name the module `neg' just for an addl test
   (test/spec-failed
@@ -4899,7 +4899,7 @@ so that propagation occurs.
                (define i #f)
                (provide/contract [i integer?])))
       (eval '(require 'neg)))
-   "'neg")
+   "module 'neg")
   
   ;; this test doesn't pass yet ... waiting for support from define-struct
   
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index bdbba39713..4e52ee536b 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -1,3 +1,4 @@
+
 (load-relative "loadtest.ss")
 (Section 'contract)
 
@@ -75,7 +76,7 @@
         (equal?
          blame
          (cond
-           [(regexp-match #rx"(^| )([^ ]*) broke" msg) 
+           [(regexp-match #rx"(^| )(.*) broke" msg) 
             =>
             (λ (x) (caddr x))]
            [else (format "no blame in error message: \"~a\"" msg)])))
@@ -97,8 +98,8 @@
                (and (exn? exn)
                     (,has-proper-blame? (exn-message exn))))))))))
   
-  (define (test/pos-blame name expression) (test/spec-failed name expression "pos"))
-  (define (test/neg-blame name expression) (test/spec-failed name expression "neg"))
+  (define (test/pos-blame name expression) (test/spec-failed name expression "module pos"))
+  (define (test/neg-blame name expression) (test/spec-failed name expression "module neg"))
   
   (define (test/well-formed stx)
     (contract-eval
@@ -120,7 +121,7 @@
         (contract-eval `(,test #t flat-contract? ,contract))
         (test/spec-failed (format "~a fail" name)
                           `(contract ,contract ',fail 'pos 'neg)
-                          "pos")
+                          "module pos")
         (test/spec-passed/result
          (format "~a pass" name)
          `(contract ,contract ',pass 'pos 'neg)
@@ -2160,6 +2161,250 @@
 
   
 
+;                                                                                           
+;                                                                                           
+;                                                                                           
+;        ;          ;;;;                  ;                                                 
+;       ;;         ;   ;                  ;                                                 
+;        ;         ;                     ;                        ;                      ;  
+;        ;         ;                     ;                        ;                      ;  
+;     ;; ;   ;;;  ;;;; ;  ; ;;    ;;;    ;   ;;;     ;;    ; ;;  ;;;; ; ;;  ;;;    ;;;  ;;;;
+;    ;  ;;  ;   ;  ;  ;; ;;;  ;  ;   ;  ;   ;   ;   ;  ;  ;;;  ;  ;  ;;;   ;   ;  ;   ;  ;  
+;   ;    ;  ;;;;;  ;   ;  ;   ;  ;;;;;  ;   ;      ;    ;  ;   ;  ;   ;       ;;  ;      ;  
+;   ;    ;  ;      ;   ;  ;   ;  ;      ;   ;      ;    ;  ;   ;  ;   ;     ;; ;  ;      ;  
+;   ;    ;  ;      ;   ;  ;   ;  ;      ;   ;      ;    ;  ;   ;  ;   ;    ;   ;  ;      ;  
+;    ;  ;;; ;   ;  ;   ;  ;   ;  ;   ; ;    ;   ;   ;  ;   ;   ;  ; ; ;    ;  ;;  ;   ;  ; ;
+;     ;; ;   ;;;  ;;;;;;;;;; ;;;  ;;;  ;     ;;;     ;;   ;;; ;;; ;; ;;;    ;; ;;  ;;;   ;; 
+;                                                                                           
+;                                                                                           
+;                                                                                           
+
+  (test/spec-passed
+   'define/contract1
+   '(let ()
+      (define/contract i integer? 1)
+      i))
+  
+  (test/spec-failed
+   'define/contract2
+   '(let ()
+      (define/contract i integer? #t)
+      i)
+   "definition i")
+  
+  (test/spec-failed
+   'define/contract3
+   '(let ()
+      (define/contract i (-> integer? integer?) (lambda (x) #t))
+      (i 1))
+   "definition i")
+  
+  (test/spec-failed
+   'define/contract4
+   '(let ()
+      (define/contract i (-> integer? integer?) (lambda (x) 1))
+      (i #f))
+   "module top-level")
+  
+  (test/spec-failed
+   'define/contract5
+   '(let ()
+      (define/contract (i x) (-> integer? integer?) 1)
+      (i #f))
+   "module top-level")
+  
+  (test/spec-passed
+   'define/contract6
+   '(let ()
+      (define/contract (i x) (-> integer? integer?)
+        (cond
+          [(not (integer? x)) 1]
+          [else (i #f)]))
+      (i 1)))
+  
+  (test/spec-passed
+   'define/contract7
+   '(let ()
+      (define/contract (contracted-func label t)
+                       (string?  string? . -> . string?)
+                       t)
+      (contracted-func
+       "I'm a string constant with side effects"
+       "ans")))
+
+  (test/spec-passed
+   'define/contract8
+   '(let ()
+      (eval '(module contract-test-suite-define1 scheme/base
+               (require scheme/contract)
+               (define/contract x string? "a")
+               x))
+      (eval '(require 'contract-test-suite-define1))))
+  
+  (test/spec-failed
+   'define/contract9
+   '(let ()
+      (define/contract (a n)
+        (-> number? number?)
+        (define/contract (b m)
+          (-> number? number?)
+          (+ m 1))
+        (b (zero? n)))
+      (a 5))
+   "function a")
+  
+  (test/spec-failed
+   'define/contract10
+   '(let ()
+      (define/contract (a n)
+        (-> number? number?)
+        (define/contract (b m)
+          (-> number? number?)
+          #t)
+        (b (add1 n)))
+      (a 5))
+   "function b")
+  
+  (test/spec-passed
+   'define/contract11
+   '(let ()
+      (define/contract (f n)
+        (-> number? number?)
+        (+ n 1))
+      (define/contract (g b m)
+        (-> boolean? number? number?)
+        (if b (f m) (f #t)))
+      (g #t 3)))
+  
+  (test/spec-failed
+   'define/contract12
+   '(let ()
+      (define/contract (f n)
+        (-> number? number?)
+        (+ n 1))
+      (define/contract (g b m)
+        (-> boolean? number? number?)
+        (if b (f m) (f #t)))
+      (g #f 3))
+   "function g")
+
+  (test/spec-failed
+   'define/contract13
+   '(begin
+      (eval '(module foo-dc13 scheme/base
+	       (require scheme/contract)
+	       (define/contract (foo-dc13 n)
+		 (-> number? number?)
+		 (+ n 1))
+	       (foo-dc13 #t)))
+      (eval '(require 'foo-dc13)))
+   "module 'foo-dc13")
+  
+  (test/spec-failed
+   'define/contract14
+   '(begin
+      (eval '(module foo-dc14 scheme/base
+	       (require scheme/contract)
+	       (provide foo-dc14)
+	       (define/contract (foo-dc14 n)
+		 (-> number? number?)
+		 (+ n 1))))
+      (eval '(module bar-dc14 scheme/base
+	       (require 'foo-dc14)
+	       (foo-dc14 #t)))
+      (eval '(require 'bar-dc14)))
+   "module 'bar-dc14")
+
+  (test/spec-failed
+   'define/contract15
+   '(begin
+      (eval '(module foo-dc15 scheme/base
+	       (require scheme/contract)
+	       (provide foo-dc15)
+	       (define/contract (foo-dc15 n)
+		 (-> number? number?)
+		 (+ n 1))))
+      (eval '(require 'foo-dc15))
+      (eval '(foo-dc15 #t)))
+   "module top-level")
+  
+
+;                                                                                  
+;                                                                                  
+;                                                                                  
+;              ;      ;                                                            
+;                    ;;                                                            
+;                 ;   ;                                  ;                      ;  
+;                 ;   ;                                  ;                      ;  
+;  ;;; ;;; ;;; ; ;;;; ; ;;          ;;;     ;;    ; ;;  ;;;; ; ;;  ;;;    ;;;  ;;;;
+;   ;   ;   ; ;;  ;   ;;  ;        ;   ;   ;  ;  ;;;  ;  ;  ;;;   ;   ;  ;   ;  ;  
+;   ;   ;   ;  ;  ;   ;   ;        ;      ;    ;  ;   ;  ;   ;       ;;  ;      ;  
+;    ; ; ; ;   ;  ;   ;   ;  ;;;;  ;      ;    ;  ;   ;  ;   ;     ;; ;  ;      ;  
+;    ; ; ; ;   ;  ;   ;   ;        ;      ;    ;  ;   ;  ;   ;    ;   ;  ;      ;  
+;    ;;  ;;    ;  ; ; ;   ;        ;   ;   ;  ;   ;   ;  ; ; ;    ;  ;;  ;   ;  ; ;
+;     ;   ;   ;;; ;; ;;; ;;;        ;;;     ;;   ;;; ;;; ;; ;;;    ;; ;;  ;;;   ;; 
+;                                                                                  
+;                                                                                  
+;                                                                                  
+
+  (test/spec-passed
+   'with-contract1
+   '(let ()
+      (with-contract odd-even
+        ([odd? (-> number? boolean?)]
+         [even? (-> number? boolean?)])
+        (define (odd? n)
+          (if (zero? n) #f (even? (sub1 n))))
+        (define (even? n)
+          (if (zero? n) #t (odd? (sub1 n)))))
+      (odd? 5)))
+  
+  (test/spec-failed
+   'with-contract2
+   '(let ()
+      (with-contract odd-even
+        ([odd? (-> number? boolean?)]
+         [even? (-> number? boolean?)])
+        (define (odd? n)
+          (if (zero? n) #f (even? (sub1 n))))
+        (define (even? n)
+          (if (zero? n) #t (odd? (sub1 n)))))
+      (odd? #t))
+   "module top-level")
+  
+  (test/spec-failed
+   'with-contract3
+   '(let ()
+      (with-contract odd-even
+        ([odd? (-> number? boolean?)]
+         [even? (-> number? boolean?)])
+        (define (odd? n)
+          (if (zero? n) n (even? (sub1 n))))
+        (define (even? n)
+          (if (zero? n) #t (odd? (sub1 n)))))
+      (odd? 4))
+   "region odd-even")
+  
+  ;; Functions within the same with-contract region can call
+  ;; each other however they want, so here we have even?
+  ;; call odd? with a boolean, even though its contract in
+  ;; the odd-even contract says it only takes numbers.
+  (test/spec-passed
+   'with-contract4
+   '(let ()
+      (with-contract odd-even
+        ([odd? (-> number? boolean?)]
+         [even? (-> number? boolean?)])
+        (define (odd? n)
+          (cond
+            [(not (number? n)) #f]
+            [(zero? n) #f]
+            [else (even? (sub1 n))]))
+        (define (even? n)
+          (if (zero? n) #t (odd? (zero? n)))))
+      (odd? 5)))
+
+
 ;                                                                                                                         
 ;                                                                                                                         
 ;                                                                                                                         
@@ -5380,7 +5625,7 @@ so that propagation occurs.
                (provide/contract (x integer?))))
       (eval '(require 'contract-test-suite3))
       (eval 'x))
-   "'contract-test-suite3")
+   "module 'contract-test-suite3")
   
   (test/spec-passed
    'provide/contract4
@@ -5557,7 +5802,7 @@ so that propagation occurs.
                             (make-s 1 2)
                             [s-a #f])))
       (eval '(require 'pc11b-n)))
-   'n)
+   "module 'n")
 |#
   
   (test/spec-passed
@@ -5625,7 +5870,7 @@ so that propagation occurs.
                (define i #f)
                (provide/contract [i integer?])))
       (eval '(require 'pos)))
-   "'pos")
+   "module 'pos")
   
   ;; this is really a positive violation, but name the module `neg' just for an addl test
   (test/spec-failed
@@ -5636,7 +5881,7 @@ so that propagation occurs.
                (define i #f)
                (provide/contract [i integer?])))
       (eval '(require 'neg)))
-   "'neg")
+   "module 'neg")
   
   ;; this test doesn't pass yet ... waiting for support from define-struct