diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss
index 632f613ead..fe58d91bf5 100644
--- a/collects/mzlib/private/unit-contract.ss
+++ b/collects/mzlib/private/unit-contract.ss
@@ -5,6 +5,7 @@
                      syntax/boundmap
                      "unit-compiletime.ss")
          scheme/contract
+         scheme/pretty
          "unit-keywords.ss"
          "unit-utils.ss"
          "unit-runtime.ss")
@@ -12,57 +13,54 @@
 (provide unit/c)
 
 (define-for-syntax (contract-imports/exports import?)
-  (λ (table-stx import-tagged-infos import-sigs ctc-table-stx pos neg src-info name)
+  (λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name)
     (define def-table (make-bound-identifier-mapping))
-    (define ctc-table (make-bound-identifier-mapping))
-    (define (convert-reference vref ctc sig-ctc)
+    
+    (define (convert-reference vref ctc sig-ctc rename-bindings)
       (let ([wrap-with-proj
-             (λ (stx)
-               #`((((proj-get ctc) ctc) #,(if import? neg pos)
-                                        #,(if import? pos neg)
-                                        #,src-info
-                                        #,name)
-                  #,stx))])
-        #`(let ([ctc #,ctc])
-            (if ctc
-                (cons (λ ()
-                        (let* ([old-v #,(if sig-ctc
-                                            #`(let ([old-v/c ((car #,vref))])
-                                                (cons #,(wrap-with-proj #'(car old-v/c))
-                                                      (cdr old-v/c)))
-                                            (wrap-with-proj #`((car #,vref))))])
-                          old-v))
-                      (λ (v) 
-                        (let* ([new-v #,(if sig-ctc
-                                            #`(cons #,(wrap-with-proj #'(car v))
-                                                    (cdr v))
-                                            (wrap-with-proj #'v))])
-                          ((cdr #,vref) new-v))))
-                #,vref))))
-    (for-each
-     (lambda (tagged-info sig)
-       (define v
-         #`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info))))
-       (define c
-         #`(hash-ref #,ctc-table-stx #,(car (tagged-info->keys tagged-info))))
-       (for-each
-        (lambda (int/ext-name index ctc)
-          (bound-identifier-mapping-put! def-table
-                                         (car int/ext-name)
-                                         #`(vector-ref #,v #,index))
-          (bound-identifier-mapping-put! ctc-table
-                                         (car int/ext-name)
-                                         #`(vector-ref #,c #,index)))
-        (car sig)
-        (build-list (length (car sig)) values)
-        (cadddr sig)))
-     import-tagged-infos
-     import-sigs)
-    (with-syntax ((((eloc ...) ...) 
-                   (map
-                    (lambda (target-sig)
-                      (map
-                       (lambda (target-int/ext-name sig-ctc)
+             (λ (ctc stx)
+               ;; If contract coersion ends up being a large overhead, we can
+               ;; store the result in a local box, then just check the box to
+               ;; see if we need to coerce.
+               #`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))])
+                   ((((proj-get ctc) ctc)
+                     #,(if import? neg pos)
+                     #,(if import? pos neg)
+                     #,src-info
+                     #,name)
+                    #,stx)))])
+        (if ctc
+            #`(cons
+               (λ ()
+                 (let* ([old-v 
+                         #,(if sig-ctc
+                               #`(let ([old-v/c ((car #,vref))])
+                                   (cons #,(wrap-with-proj ctc #'(car old-v/c))
+                                         (cdr old-v/c)))
+                               (wrap-with-proj ctc #`((car #,vref))))])
+                   old-v))
+               (λ (v) 
+                 (let* ([new-v 
+                         #,(if sig-ctc
+                               #`(cons #,(wrap-with-proj ctc #'(car v))
+                                       (cdr v))
+                               (wrap-with-proj ctc #'v))])
+                   ((cdr #,vref) new-v))))
+            vref)))
+    (for ([tagged-info (in-list import-tagged-infos)]
+          [sig         (in-list import-sigs)])
+         (let ([v #`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info)))])
+           (for ([int/ext-name (in-list (car sig))]
+                 [index        (in-list (build-list (length (car sig)) values))])
+                (bound-identifier-mapping-put! def-table
+                                               (car int/ext-name)
+                                               #`(vector-ref #,v #,index)))))
+    (with-syntax ((((eloc ...) ...)
+                   (for/list ([target-sig import-sigs])
+                     (let ([rename-bindings 
+                            (get-member-bindings def-table target-sig pos)])
+                       (for/list ([target-int/ext-name (in-list (car target-sig))]
+                                  [sig-ctc (in-list (cadddr target-sig))])
                          (let* ([vref
                                  (bound-identifier-mapping-get
                                   def-table
@@ -70,11 +68,9 @@
                                 [ctc
                                  (bound-identifier-mapping-get
                                   ctc-table
-                                  (car target-int/ext-name))])
-                           (convert-reference vref ctc sig-ctc)))
-                       (car target-sig)
-                       (cadddr target-sig)))
-                    import-sigs))
+                                  (car target-int/ext-name)
+                                  (λ () #f))])
+                           (convert-reference vref ctc sig-ctc rename-bindings))))))
                   (((export-keys ...) ...) 
                    (map tagged-info->keys import-tagged-infos)))
       #'(unit-export ((export-keys ...)
@@ -83,40 +79,6 @@
 (define-for-syntax contract-imports (contract-imports/exports #t))
 (define-for-syntax contract-exports (contract-imports/exports #f))
 
-(define-for-syntax (build-contract-table import? import-tagged-infos import-sigs id-stx ctc-stx)
-  (with-syntax ([((ectc ...) ...)
-                 (map (λ (sig ids ctcs)
-                        (let ([alist (map cons (syntax->list ids) (syntax->list ctcs))])
-                          (map (λ (int/ext-name)
-                                 (cond
-                                   [(assf (λ (i)
-                                            (bound-identifier=? i (car int/ext-name)))
-                                          alist)
-                                    =>
-                                    (λ (p) (cdr p))]
-                                   [else #'#f]))
-                               (car sig))))
-                      import-sigs 
-                      (syntax->list id-stx) 
-                      (syntax->list ctc-stx))]
-                [((export-keys ...) ...)
-                 (map tagged-info->keys import-tagged-infos)])
-    #'(unit-export ((export-keys ...) (vector-immutable ectc ...)) ...)))
-
-(define-for-syntax (check-ids name sig alist)
-  (let ([ctc-sig/ids (assf (λ (i)
-                             (bound-identifier=? name i))
-                           alist)])
-    (when ctc-sig/ids
-      (let ([ids (map car (car sig))])
-        (for-each (λ (id)
-                    (unless (memf (λ (i) (bound-identifier=? id i)) ids)
-                      (raise-syntax-error 'unit/c
-                                          (format "identifier not member of signature ~a" 
-                                                  (syntax-e name))
-                                          id)))
-                  (cdr ctc-sig/ids))))))
-
 (define-syntax/err-param (unit/c stx)
   (begin
     (define-syntax-class sig-id
@@ -152,32 +114,45 @@
                               export-tagged-sigids export-sigs)
            (process-unit-export #'(e.s ...)))
          
+         (define contract-table
+           (make-bound-identifier-mapping))
+         
+         (define (process-sig name sig xs cs)
+           (define xs-list (syntax->list xs))
+           (let ([dup (check-duplicate-identifier xs-list)])
+             (when dup
+               (raise-syntax-error 'unit/c
+                                   (format "duplicate identifier found for signature ~a"
+                                           (syntax->datum name))
+                                   dup)))
+           (let ([ids (map car (car sig))])
+             (for-each (λ (id)
+                         (unless (memf (λ (i) (bound-identifier=? id i)) ids)
+                           (raise-syntax-error 'unit/c
+                                               (format "identifier not member of signature ~a" 
+                                                       (syntax-e name))
+                                               id)))
+                       xs-list))
+           (for ([x (in-list xs-list)]
+                 [c (in-list (syntax->list cs))])
+                (bound-identifier-mapping-put! contract-table x c)))
+         
          (check-duplicate-sigs import-tagged-infos isig null null)
          
          (check-duplicate-subs export-tagged-infos esig)
          
          (check-unit-ie-sigs import-sigs export-sigs)
          
-         (for-each (λ (sig xs)
-                     (let ([dup (check-duplicate-identifier (syntax->list xs))])
-                       (when dup
-                         (raise-syntax-error 'unit/c
-                                             (format "duplicate identifier found for signature ~a" (syntax->datum sig))
-                                             dup))))
-                   (syntax->list #'(i.s ... e.s ...))
-                   (syntax->list #'((i.x ...) ... (e.x ...) ...)))
-         
-         (let ([alist (map syntax->list 
-                           (syntax->list #'((i.s i.x ...) ...)))])
-           (for-each (λ (name sig)
-                       (check-ids name sig alist))
-                     isig import-sigs))
-         
-         (let ([alist (map syntax->list 
-                           (syntax->list #'((e.s e.x ...) ...)))])
-           (for-each (λ (name sig)
-                       (check-ids name sig alist))
-                     esig export-sigs))
+         (for-each process-sig
+                   isig
+                   import-sigs
+                   (syntax->list #'((i.x ...) ...))
+                   (syntax->list #'((i.c ...) ...)))
+         (for-each process-sig
+                   esig
+                   export-sigs
+                   (syntax->list #'((e.x ...) ...))
+                   (syntax->list #'((e.c ...) ...)))
          
          (with-syntax ([((import-key ...) ...)
                         (map tagged-info->keys import-tagged-infos)]
@@ -188,23 +163,20 @@
                              import-tagged-infos)]
                        [(export-name ...)
                         (map (lambda (tag/info) (car (siginfo-names (cdr tag/info))))
-                             export-tagged-infos)]
-                       [((new-ci ...) ...) (map generate-temporaries (syntax->list #'((i.c ...) ...)))]
-                       [((new-ce ...) ...) (map generate-temporaries (syntax->list #'((e.c ...) ...)))])
+                             export-tagged-infos)])
            (quasisyntax/loc stx
-             (let-values ([(new-ci ...) (values (coerce-contract 'unit/c i.c) ...)] ...
-                          [(new-ce ...) (values (coerce-contract 'unit/c e.c) ...)] ...)
+             (begin
                (make-proj-contract
                 (list 'unit/c
                       (cons 'import 
                             (list (cons 'i.s
                                         (map list (list 'i.x ...) 
-                                             (build-compound-type-name new-ci ...)))
+                                             (build-compound-type-name 'i.c ...)))
                                   ...))
                       (cons 'export 
                             (list (cons 'e.s
                                         (map list (list 'e.x ...)
-                                             (build-compound-type-name new-ce ...)))
+                                             (build-compound-type-name 'e.c ...)))
                                   ...)))
                 (λ (pos neg src-info name)
                   (λ (unit-tmp)
@@ -227,39 +199,27 @@
                      (vector-immutable (cons 'export-name 
                                              (vector-immutable export-key ...)) ...)
                      (unit-deps unit-tmp)
-                     (lambda ()
+                     (λ ()
                        (let-values ([(unit-fn export-table) ((unit-go unit-tmp))])
                          (values (lambda (import-table)
-                                   (let ([import-ctc-table
-                                          #,(build-contract-table #t
-                                                                  import-tagged-infos
-                                                                  import-sigs
-                                                                  #'((i.x ...) ...)
-                                                                  #'((new-ci ...) ...))])
-                                     (unit-fn #,(contract-imports
-                                                 #'import-table
-                                                 import-tagged-infos
-                                                 import-sigs
-                                                 #'import-ctc-table
-                                                 #'pos
-                                                 #'neg
-                                                 #'src-info
-                                                 #'name))))
-                                 (let ([export-ctc-table
-                                        #,(build-contract-table #f
-                                                                export-tagged-infos
-                                                                export-sigs
-                                                                #'((e.x ...) ...)
-                                                                #'((new-ce ...) ...))])
-                                   #,(contract-exports 
-                                      #'export-table
-                                      export-tagged-infos
-                                      export-sigs
-                                      #'export-ctc-table
-                                      #'pos
-                                      #'neg
-                                      #'src-info
-                                      #'name))))))))
+                                   (unit-fn #,(contract-imports
+                                               #'import-table
+                                               import-tagged-infos
+                                               import-sigs
+                                               contract-table
+                                               #'pos
+                                               #'neg
+                                               #'src-info
+                                               #'name)))
+                                 #,(contract-exports 
+                                    #'export-table
+                                    export-tagged-infos
+                                    export-sigs
+                                    contract-table
+                                    #'pos
+                                    #'neg
+                                    #'src-info
+                                    #'name)))))))
                 (λ (v)
                   (and (unit? v)
                        (with-handlers ([exn:fail:contract? (λ () #f)])
diff --git a/collects/mzlib/private/unit-utils.ss b/collects/mzlib/private/unit-utils.ss
index 3552e67914..e4d8ac53bb 100644
--- a/collects/mzlib/private/unit-utils.ss
+++ b/collects/mzlib/private/unit-utils.ss
@@ -1,7 +1,10 @@
-#lang mzscheme
+#lang scheme/base
 
-(require (for-syntax "unit-compiletime.ss"
-                     "unit-syntax.ss"))
+(require (for-syntax scheme/base
+                     syntax/boundmap
+                     "unit-compiletime.ss"
+                     "unit-syntax.ss")
+         mzlib/contract)
 
 (provide (for-syntax build-key
                      check-duplicate-sigs
@@ -9,7 +12,9 @@
                      iota
                      process-unit-import
                      process-unit-export
-                     tagged-info->keys))
+                     tagged-info->keys
+                     id->contract-src-info
+                     get-member-bindings))
 
 (provide equal-hash-table
          unit-export)
@@ -21,8 +26,43 @@
       ((= n 0) acc)
       (else (loop (sub1 n) (cons (sub1 n) acc))))))
 
+  ;; 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 (quote-syntax #,id)
+                         #,(syntax-line id)
+                         #,(syntax-column id)
+                         #,(syntax-position id)
+                         #,(syntax-span id))
+            #,(format "~s" (syntax->datum id))))
+
 (define-syntax-rule (equal-hash-table [k v] ...)
-  (make-immutable-hash-table (list (cons k v) ...) 'equal))
+  (make-immutable-hash (list (cons k v) ...)))
+
+(define-for-syntax (get-member-bindings member-table sig blame)
+  (for/list ([i (in-list (map car (car sig)))]
+             [c (in-list (cadddr sig))])
+    (let ([add-ctc
+           (λ (v stx)
+             (if c
+                 #`(let ([v/c ((car #,stx))])
+                     (contract (let ([#,v #,c]) #,v)
+                               (car v/c) (cdr v/c) #,blame
+                               #,(id->contract-src-info v)))
+                 #`((car #,stx))))])
+      #`[#,i
+         (make-set!-transformer
+          (λ (stx)
+            (syntax-case stx (set!)
+              [x
+               (identifier? #'x)
+               #'#,(add-ctc i (bound-identifier-mapping-get
+                               member-table
+                               i))]
+              [(x . y)
+               #'(#,(add-ctc i (bound-identifier-mapping-get
+                                member-table
+                                i)) . y)])))])))
 
 (define-syntax (unit-export stx)
   (syntax-case stx ()
@@ -40,22 +80,22 @@
 ;; check-duplicate-sigs : (listof (cons symbol siginfo)) (listof syntax-object)
 ;;                        (listof (cons symbol siginfo)) (listof syntax-object) ->
 (define-for-syntax (check-duplicate-sigs tagged-siginfos sources tagged-deps dsources)
-  (define import-idx (make-hash-table 'equal))
+  (define import-idx (make-hash))
   (for-each
    (lambda (tinfo s)
      (define key (cons (car tinfo)
                        (car (siginfo-ctime-ids (cdr tinfo)))))
-     (when (hash-table-get import-idx key #f)
+     (when (hash-ref import-idx key #f)
        (raise-stx-err "duplicate import signature" s))
-     (hash-table-put! import-idx key #t))
+     (hash-set! import-idx key #t))
    tagged-siginfos
    sources)
   (for-each
    (lambda (dep s)
-     (unless (hash-table-get import-idx
-                             (cons (car dep)
-                                   (car (siginfo-ctime-ids (cdr dep))))
-                             #f)
+     (unless (hash-ref import-idx
+                       (cons (car dep)
+                             (car (siginfo-ctime-ids (cdr dep))))
+                       #f)
        (raise-stx-err "initialization dependency on unknown import" s)))
    tagged-deps
    dsources))
diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index ff1c7690cc..a9a8d49ad5 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -369,16 +369,6 @@
     (cons (car x)
           (signature-siginfo (lookup-signature (cdr 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 (quote-syntax #,id)
-                         #,(syntax-line id)
-                         #,(syntax-column id)
-                         #,(syntax-position id)
-                         #,(syntax-span id))
-            #,(format "~s" (syntax-object->datum id))))
-  
   (define-for-syntax (make-import-unboxing var loc ctc)
     (if ctc
         (quasisyntax/loc (error-syntax)
@@ -670,6 +660,12 @@
         target-import-tagged-infos
         target-import-sigs)
       (define def-table (make-bound-identifier-mapping))
+      (define ctc-table (make-bound-identifier-mapping))
+      (define sig-of-all-import-sigs
+        (list (apply append (map car import-sigs))
+              (apply append (map cadr import-sigs))
+              (apply append (map caddr import-sigs))
+              (apply append (map cadddr import-sigs))))
       (for-each
        (lambda (tagged-info sig)
          (define v
@@ -678,7 +674,10 @@
           (lambda (int/ext-name index ctc)
             (bound-identifier-mapping-put! def-table
                                            (car int/ext-name)
-                                           (cons #`(vector-ref #,v #,index) ctc)))
+                                           #`(vector-ref #,v #,index))
+            (bound-identifier-mapping-put! ctc-table
+                                           (car int/ext-name)
+                                           ctc))
           (car sig)
           (iota (length (car sig)))
           (cadddr sig)))
@@ -687,38 +686,48 @@
       (with-syntax ((((eloc ...) ...) 
                      (map
                       (lambda (target-sig)
+                        (define rename-bindings
+                          (get-member-bindings def-table 
+                                               sig-of-all-import-sigs 
+                                               #'(current-contract-region)))
                         (map
                          (lambda (target-int/ext-name target-ctc)
-                           (let ([vref/ctc
+                           (let* ([var (car target-int/ext-name)]
+                                  [vref
                                   (bound-identifier-mapping-get
                                    def-table
-                                   (car target-int/ext-name)
+                                   var
                                    (lambda ()
                                      (raise-stx-err
                                       (format (if import?
                                                   "identifier ~a is not present in new imports"
                                                   "identifier ~a is not present in old exports")
-                                              (syntax-e (car target-int/ext-name))))))])
-                             (let ([old-cl (car vref/ctc)])
-                               #`(cons
-                                  (λ ()
-                                    (let ([old-v #,(if (cdr vref/ctc)
-                                                       #`(let ([old-v/c ((car #,old-cl))])
-                                                           (contract #,(cdr vref/ctc) (car old-v/c) 
-                                                                     (cdr old-v/c) (current-contract-region)
-                                                                     #,(id->contract-src-info (car target-int/ext-name))))
-                                                       #`((car #,old-cl)))])
-                                      #,(if target-ctc
-                                            #'(cons old-v (current-contract-region))
-                                            #'old-v)))
-                                  (λ (v) (let ([new-v #,(if (cdr vref/ctc)
-                                                            #`(contract #,(cdr vref/ctc) (car v)
-                                                                        (current-contract-region) (cdr v)
-                                                                        #,(id->contract-src-info (car target-int/ext-name)))
-                                                            #'v)])
-                                           #,(if target-ctc
-                                                 #`((cdr #,old-cl) (cons new-v (current-contract-region)))
-                                                 #`((cdr #,old-cl) new-v))))))))
+                                              (syntax-e (car target-int/ext-name))))))]
+                                  [ctc (bound-identifier-mapping-get ctc-table var)])
+                             (if (or target-ctc ctc)
+                                 #`(cons
+                                    (λ ()
+                                      (let ([old-v #,(if ctc
+                                                         #`(let ([old-v/c ((car #,vref))])
+                                                             (contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
+                                                                       (car old-v/c) 
+                                                                       (cdr old-v/c) (current-contract-region)
+                                                                       #,(id->contract-src-info var)))
+                                                         #`((car #,vref)))])
+                                        #,(if target-ctc
+                                              #'(cons old-v (current-contract-region))
+                                              #'old-v)))
+                                    (λ (v) (let ([new-v #,(if ctc
+                                                              #`(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
+                                                                          (car v)
+                                                                          (current-contract-region)
+                                                                          (cdr v)
+                                                                          #,(id->contract-src-info var))
+                                                              #'v)])
+                                             #,(if target-ctc
+                                                   #`((cdr #,vref) (cons new-v (current-contract-region)))
+                                                   #`((cdr #,vref) new-v)))))
+                                 vref)))
                          (car target-sig)
                          (cadddr target-sig)))
                       target-import-sigs))
@@ -1139,7 +1148,10 @@
               (out-tags (map car tagged-out))
               (out-sigs (map caddr tagged-out))
               (dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs))))
-              (out-vec (generate-temporaries out-sigs)))
+              (out-vec (generate-temporaries out-sigs))
+              (tmarker (make-syntax-introducer))
+              (vmarker (make-syntax-introducer))
+              (tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)))
          (when dup
            (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup))))
          (with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags))
@@ -1153,25 +1165,45 @@
                        ((out-names ...)
                         (map (lambda (info) (car (siginfo-names (cdr info))))
                              out-tags))
+                       (((tmp-binding ...) ...) tmp-bindings)
+                       (((val-binding ...) ...) (map (λ (s) (map vmarker (map car (car s)))) out-sigs))
                        (((out-code ...) ...)
                         (map 
                          (lambda (os ov)
                            (map 
-                            (lambda (i v c)
-                              (if c
-                                  #`(let ([v/c ((car (vector-ref #,ov #,i)))])
-                                      (contract #,c (car v/c) (cdr v/c)
-                                                (current-contract-region)
-                                                #,(id->contract-src-info v)))
-                                  #`((car (vector-ref #,ov #,i)))))
-                            (iota (length (car os)))
-                            (map car (car os))
-                            (cadddr os)))
+                            (lambda (i)
+                              #`((car (vector-ref #,ov #,i))))
+                            (iota (length (car os)))))
                          out-sigs
-                         out-vec)))
+                         out-vec))
+                       (((val-code ...) ...)
+                        (map (λ (tbs os)
+                                  (map (λ (tb c)
+                                         (if c
+                                             #`(car #,tb)
+                                             tb))
+                                       tbs
+                                       (cadddr os)))
+                                tmp-bindings
+                                out-sigs))
+                       (((wrap-code ...) ...)
+                        (map (λ (os ov tbs)
+                               (map (λ (tb i v c)
+                                      (if c
+                                          #`(contract #,(vmarker c) (car #,tb) (cdr #,tb)
+                                                      (current-contract-region)
+                                                      #,(id->contract-src-info v))
+                                          tb))
+                                    tbs
+                                    (iota (length (car os)))
+                                    (map car (car os))
+                                    (cadddr os)))
+                             out-sigs
+                             out-vec
+                             tmp-bindings)))
            (quasisyntax/loc stx
              (begin
-               (define-values (int-binding ... ...)
+               (define-values (tmp-binding ... ...)
                  #,(syntax/loc #'unit-expr
                      (let ((unit-tmp unit-expr))
                        (check-unit unit-tmp 'define-values/invoke-unit)
@@ -1185,6 +1217,10 @@
                          (let ([out-vec (hash-table-get export-table key1)] ...)
                            (unit-fn #f)
                            (values out-code ... ...))))))
+               (define-values (val-binding ... ...)
+                 (values val-code ... ...))
+               (define-values (int-binding ... ...)
+                 (values wrap-code ... ...))
                (define-syntaxes . renames) ...
                (define-syntaxes (mac-name ...) mac-body) ... ...
                (define-values (val-name ...) val-body) ... ...)))))
diff --git a/collects/scribblings/guide/unit.scrbl b/collects/scribblings/guide/unit.scrbl
index 517b8a48fa..ab4731bf12 100644
--- a/collects/scribblings/guide/unit.scrbl
+++ b/collects/scribblings/guide/unit.scrbl
@@ -456,6 +456,159 @@ The unit @scheme[simple-factory@] is automatically provided from the
 module, inferred from the filename @filepath{simple-factory-unit.ss} by
 replacing the @filepath{-unit.ss} suffix with @schemeidfont["@"].
 
+@; ----------------------------------------
+
+@(interaction-eval #:eval toy-eval (require scheme/contract))
+
+@section{Contracts for Units}
+
+There are a couple of ways of protecting units with contracts.  One way
+is useful when writing new signatures, and the other handles the case
+when a unit must conform to an already existing signature.
+
+@subsection{Adding Contracts to Signatures}
+
+When contracts are added to a signature, then all units which implement
+that signature are protected by those contracts.  The following version
+of the @scheme[toy-factory^] signature adds the contracts previously
+written in comments:
+
+@schememod/eval[[#:file
+"contracted-toy-factory-sig.ss"
+scheme]
+
+(define-signature contracted-toy-factory^
+  ((contracted
+    [build-toys (-> integer? (listof toy?))]
+    [repaint    (-> toy? symbol? toy?)]
+    [toy?       (-> any/c boolean?)]
+    [toy-color  (-> toy? symbol?)])))
+
+(provide contracted-toy-factory^)]
+
+Now we take the previous implementation of @scheme[simple-factory@] and
+implement this version of @scheme[toy-factory^] instead:
+
+@schememod/eval[[#:file
+"contracted-simple-factory-unit.ss"
+scheme
+
+(require "contracted-toy-factory-sig.ss")]
+
+(define-unit contracted-simple-factory@
+  (import)
+  (export contracted-toy-factory^)
+
+  (printf "Factory started.\n")
+
+  (define-struct toy (color) #:transparent)
+
+  (define (build-toys n)
+    (for/list ([i (in-range n)])
+      (make-toy 'blue)))
+
+  (define (repaint t col)
+    (make-toy col)))
+
+(provide contracted-simple-factory@)
+]
+
+As before, we can invoke our new unit and bind the exports so
+that we can use them.  This time, however, misusing the exports
+causes the appropriate contract errors.
+
+@interaction[
+#:eval toy-eval
+(eval:alts (require "contracted-simple-factory-unit.ss") (void))
+(define-values/invoke-unit/infer contracted-simple-factory@)
+(build-toys 3)
+(build-toys #f)
+(repaint 3 'blue)
+]
+
+@subsection{Adding Contracts to Units}
+
+However, sometimes we may have a unit that must conform to an
+already existing signature that is not contracted.  In this case,
+we can use the @scheme[unit/c] contract combinator, which creates
+a new unit that protects parts of the wrapped unit as desired.
+
+For example, here's a version of @scheme[toy-store@] which has a
+slightly buggy implementation of the uncontracted @scheme[toy-store^]
+signature.  When we provide the new @scheme[wrapped-toy-store@] unit,
+we protect its exports.
+
+@schememod/eval[[#:file
+"wrapped-toy-store-unit.ss"
+scheme
+
+(require "toy-store-sig.ss"
+         "toy-factory-sig.ss")]
+
+(define-unit wrapped-toy-store@
+  (import toy-factory^)
+  (export toy-store^)
+
+  (define inventory null)
+
+  (define (store-color) 3) (code:comment #, @t{Not a valid color!})
+
+  (define (maybe-repaint t)
+    (if (eq? (toy-color t) (store-color))
+        t
+        (repaint t (store-color))))
+
+  (define (stock! n)
+    (set! inventory 
+          (append inventory
+                  (map maybe-repaint
+                       (build-toys n)))))
+
+  (define (get-inventory) inventory))
+
+(provide/contract
+ [wrapped-toy-store@ 
+  (unit/c (import toy-factory^)
+          (export (toy-store^
+                   [store-color (-> symbol?)]
+                   [stock! (-> integer? void?)]
+                   [get-inventory (-> (listof toy?))])))])
+]
+
+Since the result of the @scheme[unit/c] combinator is a new unit value
+which has not been defined with @scheme[define-unit] or another similar
+form, we run into problems with signature inference.  We see this below in the
+use of @scheme[define-compound-unit] instead of @scheme[define-compound-unit/infer]
+to link the two units.
+
+@interaction[
+#:eval toy-eval
+(eval:alts (require "wrapped-toy-store-unit.ss")
+           (define wrapped-toy-store@
+             (contract (unit/c (import toy-factory^)
+                               (export (toy-store^
+                                        [store-color (-> symbol?)]
+                                        [stock! (-> integer? void?)]
+                                        [get-inventory (-> (listof toy?))])))
+                       wrapped-toy-store@
+                       'wrapped-toy-store-unit
+                       'top-level
+                       (list (make-srcloc 'top-level #f #f #f #f) "wrapped-toy-store@"))))
+(define-compound-unit checked-toy-store+factory@
+  (import)
+  (export F S)
+  (link [((F : toy-factory^)) store-specific-factory@ S]
+        [((S : toy-store^)) wrapped-toy-store@ F]))
+(define-values/invoke-unit/infer checked-toy-store+factory@)
+(store-color)
+(stock! 'a)
+(code:comment #, @t{This fails because of the factory's (store-color) call})
+(stock! 4) 
+(code:comment #, @t{Since it failed, there's no inventory})
+(get-inventory)
+]
+
+
 @; ----------------------------------------
 
 @section{@scheme[unit] versus @scheme[module]}
diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss
index f44a8e58e3..360ed179bf 100644
--- a/collects/tests/units/test-unit-contracts.ss
+++ b/collects/tests/units/test-unit-contracts.ss
@@ -615,8 +615,6 @@
     (import)
     (export toy-factory^)
 
-    (printf "Factory started.\n")
-
     (define-struct toy (color) #:transparent)
 
     (define (build-toys n)
@@ -624,4 +622,99 @@
         (make-toy 'blue)))
 
     (define (repaint t col)
-      (make-toy col))))
+      (make-toy col)))
+
+  (provide toy-factory^ simple-factory@))
+
+(module m4 scheme
+  (define-signature foo^ (x? (contracted [f (-> x? boolean?)])))
+
+  (define-unit U@
+    (import)
+    (export foo^)
+    (define (x? x) #f)
+    (define (f x) (x? x)))
+
+  (define-values/invoke-unit/infer U@)
+  
+  (provide f x?))
+
+(require (prefix-in m4: 'm4))
+
+(test-runtime-error exn:fail:contract? "misuse of f by 'm4 (leaked uncontracted to top-level)"
+  (m4:f 3))
+
+(require (prefix-in m3: 'm3))
+
+(test-runtime-error exn:fail:contract? "misuse of build-toys by top-level"
+  (let ()
+    (define-values/invoke-unit/infer m3:simple-factory@)
+    (build-toys #f)))
+
+(module m5 scheme
+  (define-signature foo^ (f (contracted [x? (-> any/c boolean?)])))
+  
+  (define-unit U@
+    (import)
+    (export foo^)
+    (define (x? n) (zero? n))
+    (define (f x) (x? x)))
+  
+  (provide foo^)
+  (provide/contract
+   [U@
+    (unit/c (import)
+            (export (foo^ [f (-> x? boolean?)])))]))
+
+(require (prefix-in m5: 'm5))
+
+(define-values/invoke-unit m5:U@
+  (import)
+  (export (prefix m5: m5:foo^)))
+
+(m5:f 0)
+
+(test-runtime-error exn:fail:contract? "misuse of f exported by U@ by the top level"
+  (m5:f 3))
+
+(let ()
+  (define-signature foo^ (x? f))
+  (define-signature bar^ ((contracted [x? (-> number? boolean?)]
+                                      [f  (-> x? number?)])))
+  (define-unit U@
+    (import)
+    (export bar^)
+    (define x? zero?)
+    (define f values))
+  
+  (define-unit/new-import-export V@
+    (import)
+    (export bar^)
+    ((bar^) U@))
+  
+  (define-values/invoke-unit/infer V@)
+  
+  (f 0)
+  (test-runtime-error exn:fail:contract? "top-level broke contract on f"
+    (f 3)))
+
+(let ()
+  (define-signature foo^ ((contracted [x? (-> number? boolean?)]
+                                      [f (-> x? number?)])))
+  (define-signature bar^ (f (contracted [x? (-> any/c boolean?)])))
+  (define-unit U@
+    (import)
+    (export foo^)
+    (define x? zero?)
+    (define f values))
+  
+  (define-unit/new-import-export V@
+    (import)
+    (export bar^)
+    ((foo^) U@))
+  
+  (define-values/invoke-unit/infer V@)
+  
+  (f 0)
+  (test-runtime-error exn:fail:contract? "V@ broke contract on f"
+    (f 3)))
\ No newline at end of file