diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss
index 4f147dfc67..c59938b482 100644
--- a/collects/compiler/zo-marshal.ss
+++ b/collects/compiler/zo-marshal.ss
@@ -1,6 +1,7 @@
 #lang scheme/base
 (require compiler/zo-structs
          scheme/match
+         scheme/local
          scheme/list
          scheme/dict)
 
@@ -10,14 +11,9 @@
   
   Less sharing occurs than in the C implementation, creating much larger files
 
-  encode-all-from-module only handles one case
-
-  What is the purpose of protect-quote? It was making it so certain things (like paths) weren't being encoded correctly.
-
+  protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off
 |#
 
-;; Doesn't write as compactly as MzScheme, since list and pair sequences
-;; are not compacted, and symbols are not written in short form
 (define current-wrapped-ht (make-parameter #f))
 (define (zo-marshal top)
   (match top
@@ -318,11 +314,30 @@
   APPVALS_EXPD
   SPLICE_EXPD)
 
+(define CPT_SMALL_NUMBER_START 35)
+(define CPT_SMALL_NUMBER_END 60)
+
+(define CPT_SMALL_SYMBOL_START 60)
+(define CPT_SMALL_SYMBOL_END 80)
+
+(define CPT_SMALL_MARSHALLED_START 80)
+(define CPT_SMALL_MARSHALLED_END 92)
+
+(define CPT_SMALL_LIST_MAX 65)
+(define CPT_SMALL_PROPER_LIST_START 92)
+(define CPT_SMALL_PROPER_LIST_END (+ CPT_SMALL_PROPER_LIST_START CPT_SMALL_LIST_MAX))
+
+(define CPT_SMALL_LIST_START CPT_SMALL_PROPER_LIST_END)
+(define CPT_SMALL_LIST_END 192)
+
 (define CPT_SMALL_LOCAL_START 192)
 (define CPT_SMALL_LOCAL_END 207)
 (define CPT_SMALL_LOCAL_UNBOX_START 207)
 (define CPT_SMALL_LOCAL_UNBOX_END 222)
 
+(define CPT_SMALL_SVECTOR_START 222)
+(define CPT_SMALL_SVECTOR_END 247)
+
 (define CPT_SMALL_APPLICATION_START 247)
 (define CPT_SMALL_APPLICATION_END 255)
 
@@ -385,8 +400,11 @@
   (out-marshaled syntax-type-num (list* key val) out))
 
 (define (out-marshaled type-num val out)
-  (out-byte CPT_MARSHALLED out)
-  (out-number type-num out)
+  (if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START))
+      (out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out)
+      (begin
+        (out-byte CPT_MARSHALLED out)
+        (out-number type-num out)))
   (out-data val out))
 
 (define (out-anything v out)
@@ -537,7 +555,9 @@
 (define (encode-all-from-module all)
   (match all
     [(struct all-from-module (path phase src-phase exceptions prefix))
-     (list* path phase src-phase)]))
+     (if (and (empty? exceptions) (not prefix))
+         (list* path phase src-phase)
+         (list* path phase src-phase (append exceptions prefix)))]))
 
 (define (encode-wraps wraps)
   (for/list ([wrap (in-list wraps)])
@@ -592,7 +612,7 @@
                   [(struct stx (encoded))
                    (out-byte CPT_STX out)
                    (out-wrapped encoded out)]))))
-              
+
 (define (out-form form out)
   (match form
     [(? mod?)
@@ -734,13 +754,14 @@
      (out-expr (protect-quote then) out)
      (out-expr (protect-quote else) out)]
     [(struct application (rator rands))
-     (if ((length rands) . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START))
-         (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out)
-         (begin
-           (out-byte CPT_APPLICATION out)
-           (out-number (length rands) out)))
-     (for-each (lambda (e) (out-expr (protect-quote e) out))
-               (cons rator rands))]
+     (let ([len (length rands)]) 
+       (if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START))
+           (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out)
+           (begin
+             (out-byte CPT_APPLICATION out)
+             (out-number len out)))
+       (for-each (lambda (e) (out-expr (protect-quote e) out))
+                 (cons rator rands)))]
     [(struct apply-values (proc args-expr))
      (out-syntax APPVALS_EXPD
                  (cons (protect-quote proc)
@@ -852,11 +873,15 @@
                    #f
                    out)]     
     [(symbol? expr)
-     (out-as-bytes expr 
-                   (compose string->bytes/utf-8 symbol->string) 
-                   CPT_SYMBOL
-                   #f
-                   out)]
+     (out-shared expr out
+                 (lambda ()
+                   (define bs (string->bytes/utf-8 (symbol->string expr)))
+                   (define len (bytes-length bs))
+                   (if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START))
+                       (out-byte (+ CPT_SMALL_SYMBOL_START len) out)
+                       (begin (out-byte CPT_SYMBOL out)
+                              (out-number len out)))
+                   (out-bytes bs out)))]
     [(keyword? expr)
      (out-as-bytes expr 
                    (compose string->bytes/utf-8 keyword->string) 
@@ -886,8 +911,12 @@
      (out-number (char->integer expr) out)]
     [(and (exact-integer? expr)
           (and (expr . >= . -1073741824) (expr . <= . 1073741823)))
-     (out-byte CPT_INT out)
-     (out-number expr out)]
+     (if (and (expr . >= . 0)
+              (expr . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START)))
+         (out-byte (+ CPT_SMALL_NUMBER_START expr) out)
+         (begin
+           (out-byte CPT_INT out)
+           (out-number expr out)))]
     [(null? expr)
      (out-byte CPT_NULL out)]
     [(eq? expr #t)
@@ -900,10 +929,46 @@
      (out-byte CPT_BOX out)
      (out-data (unbox expr) out)]
     [(pair? expr)
-     (out-byte CPT_LIST out)
-     (out-number 1 out)
-     (out-data (car expr) out)
-     (out-data (cdr expr) out)]
+     (local [(define seen? (make-hasheq)) ; XXX Maybe this should be global?
+             (define (list-length-before-cycle/improper-end l)
+               (if (hash-has-key? seen? l)
+                   (begin (values 0 #f))
+                   (begin (hash-set! seen? l #t)
+                          (cond
+                            [(null? l)
+                             (values 0 #t)]
+                            [(pair? l)
+                             (let-values ([(len proper?)
+                                           (list-length-before-cycle/improper-end (cdr l))])
+                               (values (add1 len) proper?))]
+                            [else
+                             (values 0 #f)]))))
+             (define-values (len proper?) (list-length-before-cycle/improper-end expr))
+             (define (print-contents-as-proper)
+               (for ([e (in-list expr)])
+                 (out-data e out)))
+             (define (print-contents-as-improper)
+               (let loop ([l expr] [i len])
+                 (cond
+                   [(zero? i)
+                    (out-data l out)]
+                   [else
+                    (out-data (car l) out)
+                    (loop (cdr l) (sub1 i))])))]
+       (if proper?
+           (if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START))
+               (begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out)
+                      (print-contents-as-proper))
+               (begin (out-byte CPT_LIST out)
+                      (out-number len out)
+                      (print-contents-as-proper)
+                      (out-data null out)))
+           (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START))
+               (begin (out-byte (+ CPT_SMALL_LIST_START len) out)
+                      (print-contents-as-improper))
+               (begin (out-byte CPT_LIST out)
+                      (out-number len out)
+                      (print-contents-as-improper)))))]
     [(vector? expr)
      (out-byte CPT_VECTOR out)
      (out-number (vector-length expr) out)
@@ -921,10 +986,13 @@
        (out-data k out)
        (out-data v out))]
     [(svector? expr)
-     (out-byte CPT_SVECTOR out)
-     (out-number (vector-length (svector-vec expr)) out)
-     (let ([vec (svector-vec expr)])
-       (for ([n (in-range (sub1 (vector-length vec)) -1 -1)])
+     (let* ([vec (svector-vec expr)]
+            [len (vector-length vec)])
+       (if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START))
+           (out-byte (+ CPT_SMALL_SVECTOR_START len) out)
+           (begin (out-byte CPT_SVECTOR out)
+                  (out-number len out)))
+       (for ([n (in-range (sub1 len) -1 -1)])
          (out-number (vector-ref vec n) out)))]
     [(module-path-index? expr)
      (out-shared expr out 
@@ -958,8 +1026,8 @@
 (define (protect-quote v)
   v
   #;(if (or (list? v) (vector? v) (box? v) (hash? v))
-      (make-quoted v)
-      v))
+        (make-quoted v)
+        v))
 
 
 (define-struct svector (vec))
diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss
index c6d1e0b9e3..c130288e49 100644
--- a/collects/compiler/zo-parse.ss
+++ b/collects/compiler/zo-parse.ss
@@ -27,6 +27,10 @@
 
   I think parse-module-path-index was only used for debugging, so it is short-circuited now
 
+ collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (#<module-path-index> 0 (1363072) . #f) --- that doesn't seem to match the spec
+
+  We seem to leave placeholders for hash-tables in the structs
+
 |#
 ;; ----------------------------------------
 ;; Bytecode unmarshalers for various forms
@@ -598,6 +602,8 @@
                                              (if kind 'marked 'normal)
                                              set-id
                                              (let ([results (map (lambda (u)
+                                                                   ; u = (list path phase . src-phase)
+                                                                   ; or u = (list path phase src-phase exn ... . prefix)
                                                                    (let ([just-phase? (let ([v (cddr u)])
                                                                                         (or (number? v) (not v)))])
                                                                      (let-values ([(exns prefix)
diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss
index cb64ab7600..35aa44c1f5 100644
--- a/collects/drscheme/private/rep.ss
+++ b/collects/drscheme/private/rep.ss
@@ -262,7 +262,18 @@ TODO
          [add-drs-function
           (λ (name f)
             (send drs-bindings-keymap add-function name
-                  (λ (obj evt) (cond [(get-frame obj) => f]))))])
+                  (λ (obj evt) (cond [(get-frame obj) => f]))))]
+         [show-tab
+          (λ (i)
+            (λ (obj evt)
+              (let ([fr (get-frame obj)])
+                (and fr
+                     (is-a? fr drscheme:unit:frame<%>)
+                     (< i (send fr get-tab-count))
+                     (begin (send fr change-to-nth-tab i)
+                            #t)))))])
+    (for ([i (in-range 1 10)])
+      (send drs-bindings-keymap add-function (format "show-tab-~a" i) (show-tab (- i 1))))
     (send drs-bindings-keymap add-function "search-help-desk"
           (λ (obj evt)
             (if (not (and (is-a? obj text%) (get-frame obj))) ; is `get-frame' needed?
@@ -300,6 +311,14 @@ TODO
   
   (send drs-bindings-keymap map-function "c:x;0" "collapse")
   (send drs-bindings-keymap map-function "c:x;2" "split")
+
+  (for ([i (in-range 1 10)])
+    (send drs-bindings-keymap map-function 
+          (format "a:~a" i) 
+          (format "show-tab-~a" i))
+    (send drs-bindings-keymap map-function 
+          (format "m:~a" i) 
+          (format "show-tab-~a" i)))
   
   (define (get-drs-bindings-keymap) drs-bindings-keymap)
   
diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss
index a9ab136f02..15a8ba5033 100644
--- a/collects/drscheme/private/unit.ss
+++ b/collects/drscheme/private/unit.ss
@@ -2081,12 +2081,20 @@ module browser threading seems wrong.
               (send tabs-panel set-item-label (send tab get-i) label))))
         
         (define/private (get-defs-tab-label defs tab)
-          (let ([fn (send defs get-filename)])
-            (add-modified-flag 
-             defs
-             (if fn
-                 (get-tab-label-from-filename fn)
-                 (send defs get-filename/untitled-name)))))
+          (let ([fn (send defs get-filename)]
+                [i-prefix (or (for/or ([i (in-list tabs)]
+                                       [n (in-naturals 1)]
+                                       #:when (<= n 9))
+                                (and (eq? i tab)
+                                     (format "~a: " n)))
+                              "")])
+            (string-append
+             i-prefix
+             (add-modified-flag 
+              defs
+              (if fn
+                  (get-tab-label-from-filename fn)
+                  (send defs get-filename/untitled-name))))))
         
         (define/private (get-tab-label-from-filename fn)
           (let* ([take-n
@@ -2909,7 +2917,8 @@ module browser threading seems wrong.
         (define/public (open-in-new-tab filename)
           (create-new-tab filename))
         
-        (define/private (change-to-nth-tab n)
+        (define/public (get-tab-count) (length tabs))
+        (define/public (change-to-nth-tab n)
           (unless (< n (length tabs))
             (error 'change-to-nth-tab "number too big ~s" n))
           (change-to-tab (list-ref tabs n)))
diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss
index 04535d4c6b..9fe2e7e0fe 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "19feb2010")
+#lang scheme/base (provide stamp) (define stamp "20feb2010")
diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss
index aa30d49080..581e5efa99 100644
--- a/collects/scheme/contract/private/provide.ss
+++ b/collects/scheme/contract/private/provide.ss
@@ -17,7 +17,7 @@
     [(_ name x) (a:known-good-contract? #'x) #'x]
     [(_ name x) #'(coerce-contract name x)]))
 
-(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
+(define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
   (make-set!-transformer
    (let ([saved-id-table (make-hasheq)])
      (λ (stx)
@@ -30,6 +30,7 @@
                         ;; No: lift the contract creation:
                         (with-syntax ([contract-id contract-id]
                                       [id id]
+                                      [external-id external-id]
                                       [pos-module-source pos-module-source]
                                       [id-ref (syntax-case stx (set!)
                                                 [(set! whatever e)
@@ -45,7 +46,7 @@
                                         id
                                         pos-module-source
                                         (quote-module-path)
-                                        'id
+                                        'external-id
                                         (quote-syntax id))))))])
                (when key
                  (hash-set! saved-id-table key lifted-id))
@@ -655,6 +656,7 @@
                                    (define-syntax id-rename
                                      (make-provide/contract-transformer (quote-syntax contract-id)
                                                                         (quote-syntax id)
+                                                                        (quote-syntax external-name)
                                                                         (quote-syntax pos-module-source)))
                                    
                                    (provide (rename-out [id-rename external-name]))))])
diff --git a/collects/scribblings/mzc/zo-parse.scrbl b/collects/scribblings/mzc/zo-parse.scrbl
index 4fbcf8f194..1fb56be141 100644
--- a/collects/scribblings/mzc/zo-parse.scrbl
+++ b/collects/scribblings/mzc/zo-parse.scrbl
@@ -564,7 +564,7 @@ Represents a set of module and import bindings.}
                              [phase (or/c exact-integer? #f)]
                              [src-phase (or/c exact-integer? #f)]
                              [exceptions (listof symbol?)]
-                             [prefix symbol?])]{
+                             [prefix (or/c symbol? #f)])]{
 
 Represents a set of simple imports from one module within a
 @scheme[module-rename].}
diff --git a/collects/tests/compiler/zo-test.ss b/collects/tests/compiler/zo-test.ss
index 137a7866a0..b2261911bd 100644
--- a/collects/tests/compiler/zo-test.ss
+++ b/collects/tests/compiler/zo-test.ss
@@ -29,6 +29,9 @@
   (hash-update! ht phase (curry list* file) empty))
 
 (define (equal?/why-not v1 v2)
+  (define v1->v2 (make-hasheq))
+  (define (interned-symbol=? s1 s2)
+    (symbol=? (hash-ref! v1->v2 s1 s2) s2))
   (define (yield p m v1 v2)
     (error 'equal?/why-not "~a in ~a: ~S ~S"
            m (reverse p) v1 v2))
@@ -93,6 +96,13 @@
               (yield p "Unequal strings" v1 v2))]
            [_
             (yield p "Not a string on right" v1 v2)])]
+        [(? bytes?)
+         (match v2
+           [(? bytes?)
+            (unless (bytes=? v1 v2)
+              (yield p "Unequal bytes" v1 v2))]
+           [_
+            (yield p "Not a bytes on right" v1 v2)])]
         [(? path?)
          (match v2
            [(? path?)
@@ -107,30 +117,39 @@
               (yield p "Unequal numbers" v1 v2))]
            [_
             (yield p "Not a number on right" v1 v2)])]
+        [(? regexp?)
+         (match v2
+           [(? regexp?)
+            (unless (string=? (object-name v1) (object-name v2))
+              (yield p "Unequal regexp" v1 v2))]
+           [_
+            (yield p "Not a regexp on right" v1 v2)])]
         [(? symbol?)
          (match v2
            [(? symbol?)
-            (do-compare (symbol-interned?
-                         symbol-unreadable?)
-                        yield p v1 v2
-                        symbol=?)]
+            (unless (symbol=? v1 v2)
+              (cond
+                [(and (symbol-interned? v1) (not (symbol-interned? v1)))
+                 (yield p "Not interned symbol on right" v1 v2)]
+                [(and (symbol-unreadable? v1) (not (symbol-unreadable? v1)))
+                 (yield p "Not unreadable symbol on right" v1 v2)]
+                [(and (symbol-uninterned? v1) (not (symbol-uninterned? v1)))
+                 (yield p "Not uninterned symbol on right" v1 v2)]
+                [(and (symbol-uninterned? v1) (symbol-uninterned? v2))
+                 (unless (interned-symbol=? v1 v2)
+                   (yield p "Uninterned symbols don't align" v1 v2))]
+                [else
+                 (yield p "Other symbol-related problem" v1 v2)]))]
            [_
-            (yield p "Not a symbol on right" v1 v2)])]        
+            (yield p "Not a symbol on right" v1 v2)])]
+        [(? empty?)
+         (yield p "Not empty on right" v1 v2)]
         [_
          (yield p "Cannot inspect values deeper" v1 v2)])))
   (inner empty v1 v2))  
 
-(define-syntax do-compare 
-  (syntax-rules ()
-    [(_ () yield p v1 v2 =) 
-     (unless (= v1 v2)
-       (yield p (format "Not ~a" '=) v1 v2))]
-    [(_ (?1 ? ...) yield p v1 v2 =)
-     (if (?1 v1)
-         (if (?1 v2)
-             (do-compare () yield (list* '?1 p) v1 v2 =)
-             (yield p (format "Not ~a or right" '?1) v1 v2))
-         (do-compare (? ...) yield p v1 v2 =))]))
+(define (symbol-uninterned? s)
+  (not (or (symbol-interned? s) (symbol-unreadable? s))))
 
 ;; Parameters
 (define stop-on-first-error (make-parameter #f))
diff --git a/collects/tests/mzscheme/future.ss b/collects/tests/future/future.ss
similarity index 91%
rename from collects/tests/mzscheme/future.ss
rename to collects/tests/future/future.ss
index 01ba92b82e..139fc96969 100644
--- a/collects/tests/mzscheme/future.ss
+++ b/collects/tests/future/future.ss
@@ -3,6 +3,16 @@
 (Section 'future)
 (require scheme/future)
 
+#|Need to add expressions which raise exceptions inside a 
+future thunk which can be caught at the touch site 
+(as opposed to using with-handlers). 
+
+Both future and touch should be called from within a future thunk. 
+
+We should also test deep continuations.
+
+|# 
+
 ;; ----------------------------------------
 
 (test 2 
diff --git a/collects/scheme/future/test/random-future.ss b/collects/tests/future/random-future.ss
similarity index 100%
rename from collects/scheme/future/test/random-future.ss
rename to collects/tests/future/random-future.ss
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index dbb8ae2ff7..5c389ce9b3 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -8003,7 +8003,8 @@ so that propagation occurs.
       (eval '(require 'provide/contract34-m2))
       (eval 'provide/contract34-x))
    10)
-      
+  
+  
   (contract-error-test
    #'(begin
        (eval '(module pce1-bug scheme/base
@@ -8104,7 +8105,33 @@ so that propagation occurs.
      (printf ">> ~s\n" (exn-message x))
      (and (exn? x)
           (regexp-match #rx"pce8-bug" (exn-message x)))))
+
+  (contract-error-test
+   #'(begin
+       (eval '(module pce9-bug scheme
+                (define (f x) "wrong")
+                (provide/contract
+                 [rename f g
+                         (-> number? number?)])))
+       (eval '(require 'pce9-bug))
+       (eval '(g 12)))
+   (λ (x)
+     (and (exn? x)
+          (regexp-match #rx"broke the contract.*on g" (exn-message x)))))
   
+  (contract-error-test
+   #'(begin
+       (eval '(module pce10-bug scheme
+                (define (f x) "wrong")
+                (provide/contract
+                 [rename f g
+                         (-> number? number?)])))
+       (eval '(require 'pce10-bug))
+       (eval '(g 'a)))
+   (λ (x)
+     (and (exn? x)
+          (regexp-match #rx"broke the contract.*on g" (exn-message x)))))
+   
   (contract-eval
    `(,test
      'pos
diff --git a/collects/tests/typed-scheme/fail/cnt-struct-err.ss b/collects/tests/typed-scheme/fail/cnt-struct-err.ss
new file mode 100644
index 0000000000..1630775f1b
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/cnt-struct-err.ss
@@ -0,0 +1,18 @@
+#;
+(exn-pred exn:fail:contract?)
+#lang scheme/load
+
+(module m typed-scheme
+  (define-struct: x ([f : (Number -> Number)]))
+  (: my-x x)
+  (define my-x (make-x (lambda: ([z : Number]) z)))
+  (provide (all-defined-out)))
+
+(module n2 scheme/base
+  
+  (require 'm scheme/match)
+  (match my-x
+    [(struct x (f)) (f #f)]))
+
+
+(require 'n2)
\ No newline at end of file
diff --git a/collects/tests/typed-scheme/fail/struct-provide.ss b/collects/tests/typed-scheme/fail/struct-provide.ss
index 2e4f65b727..41c9b777f1 100644
--- a/collects/tests/typed-scheme/fail/struct-provide.ss
+++ b/collects/tests/typed-scheme/fail/struct-provide.ss
@@ -3,7 +3,8 @@
 #lang scheme/load
 
 (module m typed-scheme
-  (define-struct: q ())
+  (require (for-syntax scheme/base))
+  (define-syntax (q stx) #'#f)
   (provide (all-defined-out)))
 
 (module n scheme
diff --git a/collects/tests/typed-scheme/succeed/provide-struct-untyped.ss b/collects/tests/typed-scheme/succeed/provide-struct-untyped.ss
new file mode 100644
index 0000000000..57adf8c270
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/provide-struct-untyped.ss
@@ -0,0 +1,16 @@
+#lang scheme/load
+
+(module m typed-scheme
+  (define-struct: x ([f : (Number -> Number)]))
+  (: my-x x)
+  (define my-x (make-x (lambda: ([z : Number]) z)))
+  (provide (all-defined-out)))
+
+(module n2 scheme/base
+  
+  (require 'm scheme/match)
+  (match my-x
+    [(struct x (f)) (f 7)]))
+
+
+(require 'n2)
\ No newline at end of file
diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss
index 81f9e014f2..c85eb34cc5 100644
--- a/collects/typed-scheme/private/prims.ss
+++ b/collects/typed-scheme/private/prims.ss
@@ -241,6 +241,25 @@ This file defines two sorts of primitives. All of them are provided into any mod
                         'typechecker:with-handlers
                         #t))]))
 
+(define-syntax (dtsi* stx)
+  (define-syntax-class struct-name
+    #:description "struct name (with optional super-struct name)"
+    #:attributes (name super value)
+    (pattern ((~var name (static struct-info? "struct name")) super:id)
+             #:attr value (attribute name.value))
+    (pattern (~var name (static struct-info? "struct name"))
+             #:attr value (attribute name.value)
+             #:with super #f))
+  (syntax-parse stx
+    [(_ () nm:struct-name . rest)
+     (internal (quasisyntax/loc stx 
+                 (define-typed-struct-internal
+                   #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]
+    [(_ (vars:id ...) nm:struct-name . rest)
+     (internal (quasisyntax/loc stx 
+                 (define-typed-struct-internal (vars ...)
+                   #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]))
+
 (define-syntax (define-typed-struct stx)
   (define-syntax-class fld-spec
     #:literals (:)
@@ -259,12 +278,12 @@ This file defines two sorts of primitives. All of them are provided into any mod
                         '())])
        (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
                                            'typechecker:ignore #t)]
-                     [dtsi (internal (quasisyntax/loc stx (define-typed-struct-internal nm (fs ...) #,@mutable)))])
+                     [dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))])
          #'(begin d-s dtsi)))]
     [(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts)
      (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
                                          'typechecker:ignore #t)]
-                   [dtsi (internal (syntax/loc stx (define-typed-struct-internal (vars ...) nm (fs ...))))])
+                   [dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))])
        #'(begin d-s dtsi))]))
 
 (define-syntax (require-typed-struct stx)
@@ -283,7 +302,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
                                                   (reverse (list #'sel ...))
                                                   (list mut ...)
                                                   #f))))
-                       #,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
+                       (dtsi* () nm ([fld : ty] ...) #:type-only)
                        #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
                        #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
                        (require/typed maker nm lib #:struct-maker #f)
@@ -304,7 +323,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
                                                   (list #'sel ...)
                                                   (list mut ...)
                                                   #f))))
-                       #,(internal #'(define-typed-struct-internal (nm parent) ([fld : ty] ...) #:type-only))
+                       (dtsi* () (nm parent) ([fld : ty] ...) #:type-only)
                        #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
                        #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
                        (require/typed maker nm lib #:struct-maker parent)
diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss
index b50bea929d..6b6f3c5915 100644
--- a/collects/typed-scheme/private/type-contract.ss
+++ b/collects/typed-scheme/private/type-contract.ss
@@ -13,7 +13,8 @@
  (private parse-type)
  scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list
  (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c)
- (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap) (only-in scheme/class object% is-a?/c subclass?/c)))
+ (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap)
+	       (only-in scheme/class object% is-a?/c subclass?/c object-contract)))
 
 (define (define/fixup-contract? stx)
   (or (syntax-property stx 'typechecker:contract-def)
@@ -135,7 +136,10 @@
              (parameterize ([vars (cons (list n #'n* #'n*) (vars))])
                #`(flat-rec-contract n* #,(t->c b)))))]
         [(Value: #f) #'false/c]    
-        [(Instance: _) #'(is-a?/c object%)]
+        [(Instance: (Class: _ _ (list (list name fcn) ...))) 
+	 (with-syntax ([(fcn-cnts ...) (map t->c fcn)]
+		       [(names ...) name])
+		      #'(object-contract (names fcn-cnts) ...))]
         [(Class: _ _ _) #'(subclass?/c object%)]
         [(Value: '()) #'null?]
         [(Struct: nm par flds proc poly? pred? cert acc-ids)
diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss
index e9355e4d0b..fe192c15c2 100644
--- a/collects/typed-scheme/rep/type-rep.ss
+++ b/collects/typed-scheme/rep/type-rep.ss
@@ -222,6 +222,10 @@
                          acc-ids)]
     [#:key #f])
 
+;; A structure type descriptor
+;; s : struct
+(dt StructType ([s Struct?]) [#:key 'struct-type])
+
 ;; the supertype of all of these values
 (dt BoxTop () [#:fold-rhs #:base] [#:key 'box])
 (dt VectorTop () [#:fold-rhs #:base] [#:key 'vector])
diff --git a/collects/typed-scheme/typecheck/def-binding.ss b/collects/typed-scheme/typecheck/def-binding.ss
index 0b383b227c..e8c976e0fa 100644
--- a/collects/typed-scheme/typecheck/def-binding.ss
+++ b/collects/typed-scheme/typecheck/def-binding.ss
@@ -1,11 +1,13 @@
 #lang scheme/base
 
-(require scheme/contract)
+(require scheme/contract "../utils/utils.ss" scheme/struct-info)
 
 (define-struct binding (name) #:transparent)
 (define-struct (def-binding binding) (ty) #:transparent)
 (define-struct (def-stx-binding binding) () #:transparent)
+(define-struct (def-struct-stx-binding def-stx-binding) (static-info) #:transparent)
 
-(provide/contract (struct binding ([name identifier?]))
-                  (struct (def-binding binding) ([name identifier?] [ty any/c]))
-                  (struct (def-stx-binding binding) ([name identifier?])))
+(p/c (struct binding ([name identifier?]))
+     (struct (def-binding binding) ([name identifier?] [ty any/c]))
+     (struct (def-stx-binding binding) ([name identifier?]))
+     (struct (def-struct-stx-binding binding) ([name identifier?] [static-info (or/c #f struct-info?)])))
diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss
index 74b6580192..ecfc7a925e 100644
--- a/collects/typed-scheme/typecheck/provide-handling.ss
+++ b/collects/typed-scheme/typecheck/provide-handling.ss
@@ -9,9 +9,10 @@
          (private typed-renaming)
          (rep type-rep)
 	 (utils tc-utils)
-         scheme/contract/private/provide
-         unstable/syntax
-         "def-binding.ss")
+         scheme/contract/private/provide unstable/list
+         unstable/debug
+         unstable/syntax scheme/struct-info scheme/match
+         "def-binding.ss" syntax/parse)
 
 (require (for-template scheme/base
                        scheme/contract))
@@ -20,104 +21,136 @@
          get-alternate)
 
 (define (provide? form)    
-  (kernel-syntax-case form #f
+  (syntax-parse form 
+    #:literals (#%provide)
     [(#%provide . rest) form]
     [_ #f]))
 
-
 (define (remove-provides forms)
   (filter (lambda (e) (not (provide? e))) (syntax->list forms)))
 
-
 (define (renamer id #:alt [alt #f])
   (if alt
       (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt)
       (make-rename-transformer (syntax-property id 'not-free-identifier=? #t))))
 
-(define (generate-prov stx-defs val-defs pos-blame-id)
-  (define mapping (make-free-identifier-mapping))
-  (lambda (form)
-    (define (mem? i vd)
-      (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
-            [else #f]))
-    (define (lookup-id i vd)
-      (def-binding-ty (mem? i vd)))
-    (define (mk internal-id external-id)
-      (cond
-        ;; if it's already done, do nothing
-        [(free-identifier-mapping-get mapping internal-id
-                                      ;; if it wasn't there, put it in, and skip this case
-                                      (lambda ()
-                                        (free-identifier-mapping-put! mapping internal-id #t)
-                                        #f))
-         #'(begin)]
-        [(mem? internal-id val-defs)
-         =>
-         (lambda (b)
-           (with-syntax ([id internal-id]
-                         [out-id external-id])
-             (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t)
-                    =>
-                    (lambda (cnt)                                    
-                      (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]
-                                    [module-source pos-blame-id]
-                                    [the-contract (generate-temporary 'generated-contract)])
-                        #`(begin 
-                            (define the-contract #,cnt)
-                            (define-syntax cnt-id
-                              (make-provide/contract-transformer
-                               (quote-syntax the-contract)
-                               (quote-syntax id)
-                               (quote-syntax module-source)))
-                            (define-syntax export-id
-                              (if (unbox typed-context?)
-                                  (renamer #'id #:alt #'cnt-id)
-                                  (renamer #'cnt-id)))
-                            (#%provide (rename export-id out-id)))))]
-                   [else 
-                    (with-syntax ([(export-id error-id) (generate-temporaries #'(id id))])
-                      #`(begin        
-                          (define-syntax error-id
-                            (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))
-                          (define-syntax export-id
-                            (if (unbox typed-context?)
-                                (renamer #'id #:alt #'error-id)
-                                (renamer #'error-id)))
-                          (provide (rename-out [export-id out-id]))))])))]
-        [(mem? internal-id stx-defs) 
-         =>
-         (lambda (b)
-           (with-syntax ([id internal-id]
-                         [out-id external-id])
-             (with-syntax ([(export-id error-id) (generate-temporaries #'(id id))])
-               #`(begin  
-                   (define-syntax error-id
-                     (lambda (stx)
-                       (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))
-                   (define-syntax export-id
-                     (if (unbox typed-context?)
-                         (begin                           
-                           (add-alias #'export-id #'id)
-                           (renamer #'id #:alt #'error-id))
-                         (renamer #'error-id)))
-                   (provide (rename-out [export-id out-id]))))))]
-        [(eq? (syntax-e internal-id) (syntax-e external-id))
-         #`(provide #,internal-id)]
-        [else #`(provide (rename-out [#,internal-id #,external-id]))]))
-    (kernel-syntax-case form #f
+;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key
+(define mapping (make-free-identifier-mapping))
+
+(define (mem? i vd)
+  (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
+        [else #f]))
+
+;; generate-contract-defs : listof[def-binding] listof[def-binding] id -> syntax -> syntax
+;; val-defs: define-values in this module
+;; stx-defs: define-syntaxes in this module
+;; pos-blame-id: a #%variable-reference for the module
+
+;; internal-id : the id being provided 
+;; if `internal-id' is defined in this module, we will produce a (begin def ... provide) block 
+;;    and a name to provide instead of internal-id
+
+;; anything already recorded in the mapping is given an empty (begin) and the already-recorded id
+;; otherwise, we will map internal-id to the fresh id in `mapping'
+(define ((generate-prov stx-defs val-defs pos-blame-id) form)
+  ;; mk : id [id] -> (values syntax id)
+  (define (mk internal-id [new-id (generate-temporary internal-id)])
+    (cond
+      ;; if it's already done, do nothing
+      [(free-identifier-mapping-get mapping internal-id
+                                    ;; if it wasn't there, put it in, and skip this case
+                                    (lambda ()
+                                      (free-identifier-mapping-put! mapping internal-id new-id)
+                                      #f))
+       => (lambda (mapped-id)
+            (values #'(begin) mapped-id))]
+      [(mem? internal-id val-defs)
+       =>
+       (lambda (b)
+         (values
+          (with-syntax ([id internal-id])
+            (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t)
+                   =>
+                   (lambda (cnt)                                    
+                     (with-syntax ([(cnt-id) (generate-temporaries #'(id))]
+                                   [export-id new-id]
+                                   [module-source pos-blame-id]
+                                   [the-contract (generate-temporary 'generated-contract)])
+                       #`(begin 
+                           (define the-contract #,cnt)
+                           (define-syntax cnt-id
+                             (make-provide/contract-transformer
+                              (quote-syntax the-contract)
+                              (quote-syntax id)
+                              (quote-syntax out-id)
+                              (quote-syntax module-source)))
+                           (define-syntax export-id
+                             (if (unbox typed-context?)
+                                 (renamer #'id #:alt #'cnt-id)
+                                 (renamer #'cnt-id))))))]
+                  [else 
+                   (with-syntax ([(error-id) (generate-temporaries #'(id))]
+                                 [export-id new-id])
+                     #`(begin        
+                         (define-syntax error-id
+                           (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))
+                         (define-syntax export-id
+                           (if (unbox typed-context?)
+                               (renamer #'id #:alt #'error-id)
+                               (renamer #'error-id)))))]))
+          new-id))]
+      [(mem? internal-id stx-defs) 
+       =>
+       (lambda (b)
+         (define (mk-untyped-syntax defn-id internal-id)
+           (match b
+             [(struct def-struct-stx-binding (_ (? struct-info? si)))
+               (match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)])
+                 (let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e)
+                                                                             (mk e)
+                                                                             (values #'(begin) e)))
+                                                           (list* type-desc constr pred super accs))])
+                   (with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids])
+                                                                                (if (identifier? i)
+                                                                                    #`(syntax #,i)
+                                                                                    i))])
+                   #`(begin
+                       #,@defns
+                       (define-syntax #,defn-id
+                         (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))]
+             [_
+               #`(define-syntax #,defn-id
+                   (lambda (stx)
+                     (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))]))
+         (with-syntax* ([id internal-id]
+                        [export-id new-id]
+                        [(untyped-id) (generate-temporaries #'(id))])
+           (values
+            #`(begin  
+                #,(mk-untyped-syntax #'untyped-id internal-id)
+                (define-syntax export-id
+                  (if (unbox typed-context?)
+                      (begin                           
+                        (add-alias #'export-id #'id)
+                        (renamer #'id #:alt #'untyped-id))
+                      (renamer #'untyped-id))))
+            new-id)))]
+      ;; otherwise, not defined in this module, not our problem
+      [else (values #'(begin) internal-id)]))
+  ;; do-one : id [id] -> syntax
+  (define (do-one internal-id [external-id internal-id])
+    (define-values (defs id) (mk internal-id))
+    #`(begin #,defs (provide (rename-out [#,id #,external-id]))))
+  (syntax-parse form #:literals (#%provide)
       [(#%provide form ...)
-       (map 
-        (lambda (f)
-          (parameterize ([current-orig-stx f])
-            (syntax-case* f (struct rename all-defined protect all-defined-except all-from all-from-except) 
-              (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
-              [id 
-               (identifier? #'id)
-               (mk #'id #'id)]
-              [(rename in out)
-               (mk #'in #'out)]
-              [(protect . _)
-               (tc-error "provide: protect not supported by Typed Scheme")]
-              [_ (int-err "unknown provide form")])))
-        (syntax->list #'(form ...)))]
-      [_ (int-err "non-provide form! ~a" (syntax->datum form))])))
+       (for/list ([f (syntax->list #'(form ...))])
+         (parameterize ([current-orig-stx f])
+           (syntax-parse f
+             [i:id 
+              (do-one #'i)]
+             [((~datum rename) in out)
+              (do-one #'in #'out)]
+             [((~datum protect) . _)
+              (tc-error "provide: protect not supported by Typed Scheme")]
+             [_ (int-err "unknown provide form")])))]
+      [_ (int-err "non-provide form! ~a" (syntax->datum form))]))
diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss
index cbbdd5bb52..424cb02ee7 100644
--- a/collects/typed-scheme/typecheck/tc-structs.ss
+++ b/collects/typed-scheme/typecheck/tc-structs.ss
@@ -66,11 +66,11 @@
           (values (reverse getters) (reverse setters))
           (loop (cddr l) (cons (car l) getters) (cons (cadr l) setters)))))
   (match (build-struct-names nm flds #f (not setters?) nm)
-    [(list _ maker pred getters/setters ...) 
+    [(list sty maker pred getters/setters ...) 
      (if setters?
          (let-values ([(getters setters) (split getters/setters)])
-           (values maker pred getters setters))
-         (values maker pred getters/setters #f))]))
+           (values sty maker pred getters setters))
+         (values sty maker pred getters/setters #f))]))
 
 ;; gets the fields of the parent type, if they exist
 ;; Option[Struct-Ty] -> Listof[Type]
@@ -88,6 +88,7 @@
                          #:type-wrapper [type-wrapper values]
                          #:pred-wrapper [pred-wrapper values]
                          #:mutable [setters? #f]
+                         #:struct-info [si #f]
                          #:proc-ty [proc-ty #f]
                          #:maker [maker* #f]
                          #:predicate [pred* #f]
@@ -95,7 +96,7 @@
                          #:poly? [poly? #f]
                          #:type-only [type-only #f])
   ;; create the approriate names that define-struct will bind
-  (define-values (maker pred getters setters) (struct-names nm flds setters?))
+  (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
   (let* ([name (syntax-e nm)]
          [fld-types (append parent-field-types types)]
          [sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters)]
@@ -109,6 +110,7 @@
                                #:pred-wrapper pred-wrapper
                                #:maker (or maker* maker)
                                #:predicate (or pred* pred)
+                               #:struct-info si
                                #:constructor-return cret))))
 
 ;; generate names, and register the approriate types give field types and structure type
@@ -116,24 +118,28 @@
 ;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier
 (define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
                                #:wrapper [wrapper values]
+                               #:struct-info [si #f]
                                #:type-wrapper [type-wrapper values]
                                #:pred-wrapper [pred-wrapper values]
                                #:maker [maker* #f]
                                #:predicate [pred* #f]
                                #:constructor-return [cret #f])
   ;; create the approriate names that define-struct will bind
-  (define-values (maker pred getters setters) (struct-names nm flds setters?))
+  (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?))
   ;; the type name that is used in all the types
   (define name (type-wrapper (make-Name nm)))
   ;; the list of names w/ types
   (define bindings
     (append 
-     (list (cons (or maker* maker) 
-                 (wrapper (->* external-fld-types (if cret cret name))))
-           (cons (or pred* pred)
-                 (make-pred-ty (if setters?
-                                   (make-StructTop sty)
-                                   (pred-wrapper name)))))
+     (list 
+      (cons struct-type-id
+            (make-StructType sty))
+      (cons (or maker* maker)
+            (wrapper (->* external-fld-types (if cret cret name))))
+      (cons (or pred* pred)
+            (make-pred-ty (if setters?
+                              (make-StructTop sty)
+                              (pred-wrapper name)))))
      (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
        (let ([func (if setters? 
                        (->* (list name) t)
@@ -146,7 +152,7 @@
          null)))
   (register-type-name nm (wrapper sty))
   (cons
-   (make-def-stx-binding nm)
+   (make-def-struct-stx-binding nm si)
    (for/list ([e bindings])
              (let ([nm (car e)]
                    [t (cdr e)])
@@ -207,6 +213,7 @@
                    #:proc-ty proc-ty-parsed
                    #:maker maker
                    #:predicate pred
+                   #:struct-info (syntax-property nm/par 'struct-info)
 		   #:constructor-return (and cret (parse-type cret))
                    #:mutable mutable
                    #:type-only type-only))
diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss
index bf018ad186..de10ce7f3b 100644
--- a/collects/typed-scheme/types/subtype.ss
+++ b/collects/typed-scheme/types/subtype.ss
@@ -333,6 +333,12 @@
 	       (subtype* A0 t t*)]
 	      [((Instance: t) (Instance: t*))
 	       (subtype* A0 t t*)]
+              [((Class: '() '() (list (and s  (list names  meths )) ...))
+                (Class: '() '() (list (and s* (list names* meths*)) ...)))
+               (for/fold ([A A0]) 
+                         ([n names*] [m meths*])
+                         (cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))]
+                               [else (fail! s t)]))]
 	      ;; otherwise, not a subtype
 	      [(_ _) (fail! s t) #;(printf "failed")])))]))))
 
diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss
index f56fb8b3bf..d51753ad93 100644
--- a/collects/typed-scheme/utils/utils.ss
+++ b/collects/typed-scheme/utils/utils.ss
@@ -172,11 +172,9 @@ at least theoretically.
         (define-syntax-class clause
           #:literals ()
           #:attributes (i)
-          (pattern [struct nm:id (flds ...)]
-                   #:fail-unless (eq? (syntax-e #'struct) 'struct) #f
+          (pattern [(~datum struct) (~or nm:id (nm:id super:id)) (flds ...)]
 		   #:with i #'(struct-out nm))
-	  (pattern [rename out:id in:id cnt:expr]
-                   #:fail-unless (eq? (syntax-e #'rename) 'rename) #f
+	  (pattern [(~datum rename) out:id in:id cnt:expr]
                    #:with i #'(rename-out [out in]))
           (pattern [i:id cnt:expr]))
         (syntax-parse stx
diff --git a/collects/unstable/debug.ss b/collects/unstable/debug.ss
index b614fbbfe3..dd48296c8b 100644
--- a/collects/unstable/debug.ss
+++ b/collects/unstable/debug.ss
@@ -12,7 +12,10 @@
               (for/list ([arg 'args]
                          [val l])
                 (printf "\t~a: ~a~n" arg val))
-              (let ([e (apply f l)])
-                (printf "result was ~a~n" e)
+              (let ([e (with-handlers ([values (lambda (exn)
+                                                 (printf "~a raised exception ~a~n" 'f exn)
+                                                 (raise exn))])
+                         (apply f l))])
+                (printf "~a result was ~a~n" 'f e)
                 e)))]
     [(_ f . args) (debug (f . args))]))
\ No newline at end of file
diff --git a/collects/unstable/list.ss b/collects/unstable/list.ss
index f8609a42c4..5f8182c6c0 100644
--- a/collects/unstable/list.ss
+++ b/collects/unstable/list.ss
@@ -1,6 +1,7 @@
 #lang scheme/base
 (require scheme/contract
-         scheme/dict)
+         scheme/dict
+         (for-syntax scheme/base))
 
 ; list-prefix : list? list? -> boolean?
 ; Is l a prefix or r?
@@ -84,3 +85,30 @@
                  (same? key-item prev))
                (car items)
                (loop (cdr items) (cons key-item sofar)))))))
+
+;; sam added from carl
+
+(define-syntax (values->list stx)
+  (syntax-case stx ()
+    [(vl expr)
+     (syntax/loc stx
+       (call-with-values (lambda () expr) list))]))
+
+(define (map/list n f ls)
+  (cond
+   [(andmap null? ls) (build-list n (lambda (i) null))]
+   [(andmap pair? ls)
+    (let* ([vs (values->list (apply f (map car ls)))]
+           [k (length vs)])
+      (unless (= k n)
+        (error 'map/values
+               "~a produced ~a values, not ~a: ~e"
+               f k n vs))
+      (map cons vs (map/list n f (map cdr ls))))]
+   [else (error 'map/values "list lengths differ")]))
+
+(define (map/values n f . ls)
+  (apply values (map/list n f ls)))
+
+(provide map/values)
+
diff --git a/collects/unstable/scribblings/list.scrbl b/collects/unstable/scribblings/list.scrbl
index de7a524a35..fbacc79c64 100644
--- a/collects/unstable/scribblings/list.scrbl
+++ b/collects/unstable/scribblings/list.scrbl
@@ -79,3 +79,27 @@ true value. The procedures @scheme[equal?], @scheme[eqv?], and
 (dict-map id-t list)
 ]
 }
+
+                         
+@addition{Carl Eastlund}
+
+@defproc[(map/values [n natural-number/c]
+                     [f (-> A ... (values B_1 ... B_n))]
+                     [lst (listof A)]
+                     ...)
+         (values (listof B_1) ... (listof B_n))]{
+
+Produces lists of the respective values of @scheme[f] applied to the elements in
+@scheme[lst ...] sequentially.
+
+@defexamples[
+#:eval the-eval
+(map/values
+ 3
+ (lambda (x)
+   (values (+ x 1) x (- x 1)))
+ (list 1 2 3))
+]
+
+}
+