diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss
index 5f766ce8f5..55ca8ff9d6 100644
--- a/collects/drscheme/private/main.ss
+++ b/collects/drscheme/private/main.ss
@@ -94,7 +94,7 @@
                                          (number? (car x))
                                          (number? (cdr x))))))
 
-(preferences:set-default 'drscheme:child-only-memory-limit (* 1024 1024 64)
+(preferences:set-default 'drscheme:child-only-memory-limit (* 1024 1024 128)
                          (λ (x) (or (boolean? x)
                                     (integer? x)
                                     (x . >= . (* 1024 1024 1)))))
diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss
index 96af29feff..8b15e0b73b 100644
--- a/collects/drscheme/private/rep.ss
+++ b/collects/drscheme/private/rep.ss
@@ -925,7 +925,7 @@ TODO
       (field (need-interaction-cleanup? #f))
       
       (define/private (no-user-evaluation-message frame exit-code memory-killed?)
-        (let* ([new-limit (and custodian-limit (+ (* 1024 1024 32) custodian-limit))]
+        (let* ([new-limit (and custodian-limit (+ custodian-limit custodian-limit))]
                [ans (message-box/custom
                      (string-constant evaluation-terminated)
                      (string-append
diff --git a/collects/ffi/info.ss b/collects/ffi/info.ss
index de10b968fb..8209760e07 100644
--- a/collects/ffi/info.ss
+++ b/collects/ffi/info.ss
@@ -3,3 +3,5 @@
 (define name "Sample FFIs")
 
 (define compile-omit-paths '("examples"))
+
+(define scribblings '(("objc.scrbl" (multi-page) (foreign))))
diff --git a/collects/ffi/objc.scrbl b/collects/ffi/objc.scrbl
new file mode 100644
index 0000000000..00f4985c85
--- /dev/null
+++ b/collects/ffi/objc.scrbl
@@ -0,0 +1,271 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/eval
+          (for-label scheme/base
+                     scheme/foreign
+                     ffi/objc))
+
+@(define objc-eval (make-base-eval))
+@(interaction-eval #:eval objc-eval (define-struct cpointer:id ()))
+
+@(define seeCtype
+   @elem{see @secref[#:doc '(lib "scribblings/foreign/foreign.scrbl") "ctype"]})
+
+@title{@bold{Objective-C} FFI}
+
+@defmodule[ffi/objc]{The @schememodname[ffi/objc] library builds on
+@schememodname[scheme/foreign] to support interaction with
+@link["http://developer.apple.com/documentation/Cocoa/Conceptual/ObjectiveC/"]{Objective-C}.}
+
+The library supports Objective-C interaction in two layers. The upper
+layer provides syntactic forms for sending messages and deriving
+subclasses. The lower layer is a think wrapper on the
+@link["http://developer.apple.com/DOCUMENTATION/Cocoa/Reference/ObjCRuntimeRef/index.html"]{Objective-C
+runtime library} functions. Even the upper layer is unsafe and
+relatively low-level compared to normal Scheme libraries, because
+argument and result types must be declared in terms of FFI C types
+(@seeCtype).
+
+@table-of-contents[]
+
+@section{FFI Types and Constants}
+
+@defthing[_id ctype?]{
+
+The type of an Objective-C object, an opaque pointer.}
+
+@defthing[_Class ctype?]{
+
+The type of an Objective-C class, which is also an @scheme[_id].}
+
+@defthing[_SEL ctype?]{
+
+The type of an Objective-C selector, an opaque pointer.}
+
+@defthing[_BOOL ctype?]{
+
+The Objective-C boolean type. Scheme values are converted for C in the
+usual way: @scheme[#f] is false and any other value is true. C values
+are converted to Scheme booleans.}
+
+@defthing[YES boolean?]{
+
+Synonym for @scheme[#t]}
+
+@defthing[NO boolean?]{
+
+Synonym for @scheme[#f]}
+
+@; ----------------------------------------------------------------------
+
+@section{Syntactic Forms}
+
+@defform*/subs[[(tell result-type obj-expr method-id)
+                (tell result-type obj-expr arg ...)]
+               ([result-type code:blank
+                             (code:line #:type ctype-expr)]
+                [arg (code:line method-id expr)
+                     (code:line #:type ctype-expr method-id arg)])]{
+
+Sends a message to the Objective-C object produced by
+@scheme[obj-expr]. When a type is omitted for either the result or an
+argument, the type is assumed to be @scheme[_id], otherwise it must
+be specified as an FFI C type (@seeCtype).
+
+If a single @scheme[method-id] is provided with no arguments, then
+@scheme[method-id] must not end with @litchar{:}; otherwise, each
+@scheme[method-id] must end with @litchar{:}.
+
+@examples[
+#:eval objc-eval
+(eval:alts (tell NSString alloc) (make-cpointer:id))
+(eval:alts (tell (tell NSString alloc)
+                 initWithUTF8String: #:type _string "Hello")
+           (make-cpointer:id))
+]}
+
+@defform*[[(tellv obj-expr method-id)
+           (tellv obj-expr arg ...)]]{
+
+Like @scheme[tell], but with a result type @scheme[_void].}
+
+@defform[(import-class class-id ...)]{
+
+Defines each @scheme[class-id] to the class (a value with FFI type
+@scheme[_Class]) that is registered with the string form of
+@scheme[class-id]. The registered class is obtained via
+@scheme[objc_lookUpClass].
+
+@examples[
+#:eval objc-eval
+(eval:alts (import-class NSString) (void))
+]}
+
+@defform/subs[#:literals (+ -)
+              (define-objc-class class-id superclass-expr
+                [field-id ...]
+                method)
+              ([method (mode result-ctype-expr (method-id) body ...+)
+                       (mode result-ctype-expr (arg ...+) body ...+)]
+               [mode + -]
+               [arg (code:line method-id [ctype-expr arg-id])])]{
+
+Defines @scheme[class-id] as a new, registered Objective-C class (of
+FFI type @scheme[_Class]). The @scheme[superclass-expr] should
+produce an Objective-C class or @scheme[#f] for the superclass.
+
+Each @scheme[field-id] is an instance field that holds a Scheme value
+and that is initialized to @scheme[#f] when the object is
+allocated. The @scheme[field-id]s can be referenced and @scheme[set!]
+directly when the method @scheme[body]s. Outside the object, they can
+be referenced and set with @scheme[get-ivar] and @scheme[set-ivar!].
+
+Each @scheme[method] adds or overrides a method to the class (when
+@scheme[mode] is @scheme[-]) to be called on instances, or it adds a
+method to the meta-class (when @scheme[mode] is @scheme[+]) to be
+called on the class itself. All result and argument types must be
+declared using FFI C types (@seeCtype).
+
+If a @scheme[method] is declared with a single @scheme[method-id] and
+no arguments, then @scheme[method-id] must not end with
+@litchar{:}. Otherwise, each @scheme[method-id] must end with
+@litchar{:}.
+
+If the special method @scheme[dealloc] is declared for mode
+@scheme[-], it must not call the superclass method, because a
+@scheme[(super-tell dealloc)] is added to the end of the method
+automatically. In addition, before @scheme[(super-tell dealloc)],
+space for each @scheme[field-id] within the instance is deallocated.
+
+@examples[
+#:eval objc-eval
+(eval:alts
+ (define-objc-class MyView NSView
+   [bm] (code:comment #, @elem{<- one field})
+   (- _scheme (swapBitwmap: [_scheme new-bm])
+      (begin0 bm (set! bm new-bm)))
+   (- _void (drawRect: [#, @schemeidfont{_NSRect} exposed-rect])
+      (super-tell drawRect: exposed-rect)
+      (draw-bitmap-region bm exposed-rect))
+   (- _void (dealloc)
+      (when bm (done-with-bm bm))))
+ (void))
+]}
+
+@defidform[self]{
+
+When used within the body of a @scheme[define-objc-class] method,
+refers to the object whose method was called. This form cannot be used
+outside of a @scheme[define-objc-class] method.}
+
+@defform*[[(super-tell result-type method-id)
+           (super-tell result-type arg ...)]]{
+
+When used within the body of a @scheme[define-objc-class] method,
+calls a superclass method. The @scheme[result-type] and @scheme[arg]
+sub-forms have the same syntax as in @scheme[tell]. This form cannot
+be used outside of a @scheme[define-objc-class] method.}
+
+
+@defform[(get-ivar obj-expr field-id)]{
+
+Extracts the Scheme value of a field in a class created with
+@scheme[define-objc-class].}
+
+@defform[(set-ivar! obj-expr field-id value-expr)]{
+
+Sets the Scheme value of a field in a class created with
+@scheme[define-objc-class].}
+
+@defform[(selector method-id)]{
+
+Returns a selector (of FFI type @scheme[_SEL]) for the string form of
+@scheme[method-id].
+
+@examples[
+(eval:alts (tellv button setAction: #:type _SEL (selector terminate:)) (void))
+]}
+
+@; ----------------------------------------------------------------------
+
+@section{Raw Runtime Functions}
+
+@defproc[(objc_lookUpClass [s string?]) (or/c _Class #f)]{
+
+Finds a registered class by name.}
+
+@defproc[(sel_registerName [s string?]) _SEL]{
+
+Interns a selector given its name in string form.}
+
+@defproc[(objc_allocateClassPair [cls _Class] [s string?] [extra integer?])
+         _Class]{
+
+Allocates a new Objective-C class.}
+
+@defproc[(objc_registerClassPair [cls _Class]) void?]{
+
+Registers an Objective-C class.}
+
+@defproc[(object_getClass [obj _id]) _Class]{
+
+Returns the class of an object (or the meta-class of a class).}
+
+@defproc[(class_addMethod [cls _Class] [sel _SEL] 
+                          [imp procedure?]
+                          [type ctype?]
+                          [type-encoding string?])
+         boolean?]{
+
+Adds a method to a class. The @scheme[type] argument must be a FFI C
+type (@seeCtype) that matches both @scheme[imp] and and the not
+Objective-C type string @scheme[type-encoding].}
+
+@defproc[(class_addIvar [cls _Class] [name string?] [size exact-nonnegative-integer?]
+                        [log-alignment exact-nonnegative-integer?] [type-encoding string?])
+         boolean?]{
+
+Adds an instance variable to an Objective-C class.}
+
+@defproc[(object_getInstanceVariable [obj _id]
+                                     [name string?])
+         (values _Ivar any/c)]{
+
+Gets the value of an instance variable whose type is @scheme[_pointer].}
+
+@defproc[(object_setInstanceVariable [obj _id]
+                                     [name string?]
+                                     [val any/c])
+         _Ivar]{
+
+Sets the value of an instance variable whose type is @scheme[_pointer].}
+
+@defthing[_Ivar ctype?]{
+
+The type of an Objective-C instance variable, an opaque pointer.}
+
+@defproc[((objc_msgSend/typed [types (vector/c result-ctype arg-ctype ...)])
+          [obj _id]
+          [sel _SEL]
+          [arg any/c])
+         any/c]{
+
+Calls the Objective-C method on @scheme[_id] named by @scheme[sel].
+The @scheme[types] vector must contain one more than the number of
+supplied @scheme[arg]s; the first FFI C type in @scheme[type] is used
+as the result type.}
+
+@defproc[((objc_msgSendSuper/typed [types (vector/c result-ctype arg-ctype ...)])
+          [super _objc_super]
+          [sel _SEL]
+          [arg any/c])
+         any/c]{
+
+Like @scheme[objc_msgSend/typed], but for a super call.}
+
+@deftogether[(
+@defproc[(make-obj_csuper [id _id] [super _Class]) _objc_super]
+@defthing[_objc_super ctype?]
+)]{
+
+Constructor and FFI C type use for super calls.}
diff --git a/collects/ffi/objc.ss b/collects/ffi/objc.ss
new file mode 100644
index 0000000000..37e67c5092
--- /dev/null
+++ b/collects/ffi/objc.ss
@@ -0,0 +1,550 @@
+#lang scheme/base
+(require scheme/foreign (only-in '#%foreign ffi-call)
+         scheme/stxparam
+         (for-syntax scheme/base))
+(unsafe!)
+
+(define objc-lib (ffi-lib "libobjc"))
+
+(define-syntax define-objc/private
+  (syntax-rules ()
+    [(_ id type)
+     (define-objc/private id id type)]
+    [(_ id c-id type)
+     (define id (get-ffi-obj 'c-id objc-lib type))]))
+
+(define-syntax-rule (define-objc id type)
+  (begin
+    (provide id)
+    (define-objc/private id id type)))
+
+;; ----------------------------------------
+
+(provide _id _Class _BOOL _SEL _Ivar
+         make-objc_super _objc_super)
+
+(define _id (_cpointer/null 'id))
+
+(define _SEL (_cpointer/null 'SEL))
+(define _Ivar (_cpointer/null 'Ivar))
+(define _Class (make-ctype _id
+                           (lambda (v) v)
+                           (lambda (p)
+                             (when p (cpointer-push-tag! p 'Class))
+                             p)))
+(define _BOOL (make-ctype _byte
+                          (lambda (v) (if v 1 0))
+                          (lambda (v) (not (eq? v 0)))))
+(define _IMP (_fun _id _id -> _id))
+
+(define-cstruct _objc_super ([receiver _id][class _Class]))
+
+(provide YES NO)
+(define YES #t)
+(define NO #f)
+
+;; ----------------------------------------
+
+(define-objc objc_lookUpClass (_fun _string -> _Class))
+
+(define-objc sel_registerName (_fun _string -> _SEL))
+
+(define-objc objc_allocateClassPair (_fun _Class _string _long -> _Class))
+(define-objc objc_registerClassPair (_fun _Class -> _void))
+
+(define-objc object_getClass (_fun _id -> _Class))
+
+(provide class_addMethod)
+(define (class_addMethod cls sel imp ty enc)
+  ((get-ffi-obj 'class_addMethod objc-lib (_fun _Class _SEL ty _string -> _BOOL))
+   cls sel imp enc))
+
+(define-objc class_addIvar (_fun _Class _string _long _uint8 _string -> _BOOL))
+(define-objc object_getInstanceVariable (_fun _id _string [p : (_ptr o _pointer)]
+                                              -> [ivar : _Ivar] 
+                                              -> (values ivar p)))
+(define-objc object_setInstanceVariable (_fun _id _string _pointer -> _Ivar))
+
+(define-objc/private objc_msgSend _fpointer)
+(define-objc/private objc_msgSend_fpret _fpointer)
+(define-objc/private objc_msgSendSuper _fpointer)
+(define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant?
+
+(define (lookup-send types msgSends msgSend msgSend_fpret first-arg-type)
+  ;; First type in `types' vector is the result type
+  (or (hash-ref msgSends types #f)
+      (let ([m (ffi-call (if (memq (ctype->layout (vector-ref types 0))
+                                   '(float double double*))
+                             msgSend_fpret
+                             msgSend)
+                         (list* first-arg-type _SEL (cdr (vector->list types)))
+                         (vector-ref types 0))])
+        (hash-set! msgSends types m)
+        m)))
+
+(define msgSends (make-hash))
+(define (objc_msgSend/typed types)
+  (lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id))
+(provide objc_msgSend/typed)
+
+(define msgSendSupers (make-hash))
+(define (objc_msgSendSuper/typed types)
+  (lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret _pointer))
+(provide objc_msgSendSuper/typed)
+
+;; ----------------------------------------
+
+(provide import-class)
+(define-syntax (import-class stx)
+  (syntax-case stx ()
+    [(_ id)
+     (quasisyntax/loc stx
+       (define id (objc_lookUpClass #,(symbol->string (syntax-e #'id)))))]
+    [(_ id ...)
+     (syntax/loc stx (begin (import-class id) ...))]))
+
+;; ----------------------------------------
+;; iget-value and set-ivar! work only with fields that contain Scheme values
+
+(provide get-ivar set-ivar!)
+
+(define-for-syntax (check-ivar ivar stx)
+  (unless (identifier? ivar)
+    (raise-type-error #f
+                      "expected an identifier for an instance-variable name"
+                      stx
+                      ivar)))
+
+(define-syntax (get-ivar stx)
+  (syntax-case stx ()
+    [(_ obj ivar)
+     (begin
+       (check-ivar #'ivar stx)
+       (quasisyntax/loc stx
+         (get-ivar-value obj #,(symbol->string (syntax-e #'ivar)))))]))
+
+(define (get-ivar-value obj name)
+  (let-values ([(ivar p) (object_getInstanceVariable obj name)])
+    (and p (ptr-ref p _scheme))))
+      
+
+(define-syntax (set-ivar! stx)
+  (syntax-case stx ()
+    [(_ obj ivar val)
+     (begin
+       (check-ivar #'ivar stx)
+       (quasisyntax/loc stx
+         (set-ivar-value obj #,(symbol->string (syntax-e #'ivar)) val)))]))
+
+(define (set-ivar-value obj name val)
+  (let-values ([(ivar p) (object_getInstanceVariable obj name)])
+    (if p
+        (ptr-set! p _scheme val)
+        (let ([p (malloc-immobile-cell val)])
+          (void (object_setInstanceVariable obj name p))))))
+
+(define (free-fields obj names)
+  (for-each (lambda (name)
+              (let-values ([(ivar p) (object_getInstanceVariable obj name)])
+                (when p (free-immobile-cell p))))
+            names))
+
+;; ----------------------------------------
+
+(define-for-syntax method-sels (make-hash))
+
+(define-for-syntax (register-selector sym)
+  (or (hash-ref method-sels (cons (syntax-local-lift-context) sym) #f)
+      (let ([id (syntax-local-lift-expression
+                 #`(sel_registerName #,(symbol->string sym)))])
+        (hash-set! method-sels sym id)
+        id)))
+
+(provide selector)
+(define-syntax (selector stx)
+  (syntax-case stx ()
+    [(_ id)
+     (begin
+       (unless (identifier? #'id)
+         (raise-syntax-error #f
+                             "expected an identifier"
+                             stx
+                             #'id))
+       (register-selector (syntax-e #'id)))]))
+
+;; ----------------------------------------
+
+(define-for-syntax (combine stxes)
+  (string->symbol
+   (apply
+    string-append
+    (map (lambda (e) (symbol->string (syntax-e e)))
+         (syntax->list stxes)))))
+
+(define-for-syntax (check-method-name m stx)
+  (unless (identifier? m)
+    (raise-syntax-error #f
+                        "expected an identifier for the method name"
+                        stx
+                        m)))
+
+(define-for-syntax (check-id-colon id stx)
+  (unless (regexp-match #rx":$" (symbol->string (syntax-e id)))
+    (raise-syntax-error #f
+                        "expected an identifier that ends in `:' to tag an argument"
+                        stx
+                        id)))
+
+(define-for-syntax (parse-arg-list l stx formals?)
+  (define (is-typed? l)
+    (if formals?
+        (and (pair? (cdr l))
+             (let ([l (syntax->list (cadr l))])
+               (and (list? l)
+                    (= 2 (length l)))))
+        (and (pair? (cdr l))
+             (eq? '#:type (syntax-e (cadr l))))))
+  (let loop ([l l])
+    (if (null? l)
+        null
+        (begin
+          (unless (identifier? (car l))
+            (raise-syntax-error #f
+                                "expected an identifier to tag an argument"
+                                stx
+                                (car l)))
+          (check-id-colon (car l) stx)
+          (let ([tag (car l)]
+                [type (if (is-typed? l)
+                          (if formals?
+                              (car (syntax-e (cadr l)))
+                              (if (pair? (cddr l))
+                                  (caddr l)
+                                  (raise-syntax-error #f
+                                                      "missing type expression after tag with #:type"
+                                                      stx
+                                                      (car l))))
+                          #'_id)]
+                [rest (if formals?
+                          (cdr l)
+                          (if (is-typed? l)
+                              (cdddr l)
+                              (cdr l)))])
+            (unless (pair? rest)
+              (raise-syntax-error #f
+                                  (format "missing an argument~a after tag"
+                                          (if formals? " identifier" " expression"))
+                                  stx
+                                  tag))
+            (cons
+             (list tag type (let ([arg (car rest)])
+                              (if formals?
+                                  (if (identifier? arg)
+                                      arg
+                                      (let ([l (syntax->list arg)])
+                                        (unless (and (list? l)
+                                                     (= 2 (length l))
+                                                     (identifier? (cadr l)))
+                                          (raise-syntax-error #f
+                                                              (string-append
+                                                               "exepected an identifier for an argument name"
+                                                               " or a parenthesized type--identifier sequence")
+                                                              stx
+                                                              arg))
+                                        (cadr l)))
+                                  arg)))
+             (loop (cdr rest))))))))
+
+(provide tell tellv)
+(define-for-syntax (build-send stx result-type send/typed send-args l-stx)
+  (let ([l (syntax->list  l-stx)])
+    (with-syntax ([((tag type arg) ...) (parse-arg-list l stx #f)]
+                  [send send/typed]
+                  [(send-arg ...) send-args])
+      (quasisyntax/loc stx
+        ((send (type-vector #,result-type type ...))
+         send-arg ... #,(register-selector (combine #'(tag ...)))
+         arg ...)))))
+
+(define-syntax (tell stx)
+  (syntax-case stx ()
+    [(_ target)
+     (raise-syntax-error #f
+                         "method identifier missing"
+                         stx)]
+    [(_ #:type t)
+     (raise-syntax-error #f
+                         "method target object missing"
+                         stx)]
+    [(_ #:type t target)
+     (raise-syntax-error #f
+                         "method identifier missing"
+                         stx)]
+    [(_ #:type t target method)
+     (let ([m #'method])
+       (check-method-name m stx)
+       (quasisyntax/loc stx
+         ((objc_msgSend/typed (type-vector t)) target #,(register-selector (syntax-e m)))))]
+    [(_ target method)
+     (not (keyword? (syntax-e #'target)))
+     (let ([m #'method])
+       (check-method-name m stx)
+       (quasisyntax/loc stx
+         ((objc_msgSend/typed (type-vector _id)) target #,(register-selector (syntax-e m)))))]
+    [(_ #:type result-type target method/arg ...)
+     (build-send stx #'result-type 
+                 #'objc_msgSend/typed #'(target)
+                 #'(method/arg ...))]
+    [(_ target method/arg ...)
+     (build-send stx #'_id 
+                 #'objc_msgSend/typed #'(target)
+                 #'(method/arg ...))]))
+
+(define-syntax-rule (tellv a ...)
+  (tell #:type _void a ...))
+
+(define-for-syntax liftable-type?
+  (let ([prims 
+         (syntax->list #'(_id _Class _SEL _void _int _long _float _double _double* _BOOL))])
+    (lambda (t)
+      (and (identifier? t)
+           (ormap (lambda (p) (free-identifier=? t p))
+                  prims)))))
+
+(define-syntax (type-vector stx)
+  (let ([types (cdr (syntax->list stx))])
+    ((if (andmap liftable-type? (cdr (syntax->list stx)))
+         (lambda (e)
+           (syntax-local-lift-expression #`(intern-type-vector #,e)))
+         values)
+     (quasisyntax/loc stx (vector . #,types)))))
+
+(define type-vectors (make-hash))
+(define (intern-type-vector v)
+  (or (hash-ref type-vectors v #f)
+      (begin
+        (hash-set! type-vectors v v)
+        v)))
+
+;; ----------------------------------------
+
+(provide define-objc-class self super-tell)
+
+(define-syntax (define-objc-class stx)
+  (syntax-case stx ()
+    [(_ id superclass (ivar ...) method ...)
+     (begin
+       (unless (identifier? #'id)
+         (raise-syntax-error #f
+                             "expected an identifier for class definition"
+                             stx
+                             #'id))
+       (for-each (lambda (ivar)
+                   (unless (identifier? ivar)
+                     (raise-syntax-error #f
+                                         "expected an identifier for an instance variable"
+                                         stx
+                                         ivar)))
+                 (syntax->list #'(ivar ...)))
+       (let ([ivars (syntax->list #'(ivar ...))]
+             [methods (syntax->list #'(method ...))])
+         (with-syntax ([id-str (symbol->string (syntax-e #'id))]
+                       [whole-stx stx]
+                       [(dealloc-method ...)
+                        (if (null? ivars)
+                            ;; no need to override dealloc:
+                            #'()
+                            ;; add dealloc if it's not here:
+                            (if (ormap (lambda (m)
+                                         (syntax-case m ()
+                                           [(+/- result-type (id . _) . _)
+                                            (eq? (syntax-e #'id) 'dealloc)]))
+                                       methods)
+                                ;; Given a dealloc extension:
+                                #'()
+                                ;; Need to add one explicitly:
+                                #'((- _void (dealloc) (void)))))])
+           (syntax/loc stx
+             (begin
+               (define superclass-id superclass)
+               (define id (objc_allocateClassPair superclass-id id-str 0))
+               (add-ivar id 'ivar) ...
+               (let-syntax ([ivar (make-ivar-form 'ivar)] ...)
+                 (add-method whole-stx id superclass-id method) ...
+                 (add-method whole-stx id superclass-id dealloc-method) ...
+                 (void))
+               (objc_registerClassPair id))))))]))
+
+(define-for-syntax (make-ivar-form sym)
+  (with-syntax ([sym sym])
+    (make-set!-transformer
+     (lambda (stx)
+       (syntax-case stx (set!)
+         [(set! _ val)
+          (syntax/loc stx (set-ivar! self sym val))]
+         [(_ arg ...)
+          (quasisyntax/loc stx (#,(quasisyntax/loc #'sym #'(get-ivar self sym)) 
+                                arg ...))]
+         [_ (quasisyntax/loc #'sym (get-ivar self sym))])))))
+
+(define (layout->string l)
+  (case l
+    [(uint8) "C"]
+    [(int8) "c"]
+    [(float) "f"]
+    [(double) "d"]
+    [(bool) "B"]
+    [(void) "v"]
+    [(bytes) "*"]
+    [(pointer fpointer string/ucs-4 string/utf-16) "?"]
+    [else
+     (cond
+      [(list? l)
+       (apply string-append 
+              (for/list ([l (in-list l)]
+                         [i (in-naturals)])
+                (format "f~a=~a" i (layout->string l))))]
+      [(eq? l (ctype->layout _int)) "i"]
+      [(eq? l (ctype->layout _uint)) "I"]
+      [(eq? l (ctype->layout _short)) "s"]
+      [(eq? l (ctype->layout _ushort)) "S"]
+      [(eq? l (ctype->layout _long)) "l"]
+      [(eq? l (ctype->layout _ulong)) "L"]
+      [else (error 'generate-layout "unknown layout: ~e" l)])]))
+
+(define (generate-layout rt arg-types)
+  (let ([rl (ctype->layout rt)]
+        [al (map ctype->layout arg-types)])
+    (apply
+     string-append
+     (layout->string rl)
+     "@:"
+     (map layout->string al))))
+
+(define-syntax-parameter self
+  (lambda (stx)
+    (raise-syntax-error #f
+                        "valid only within a `define-objc-class' method"
+                        stx)))
+
+(define-syntax-parameter super-class
+  (lambda (stx) #f))
+
+(define-syntax-parameter super-tell
+  (lambda (stx)
+    (raise-syntax-error #f
+                        "valid only within a `define-objc-class' method"
+                        stx)))
+
+(define-for-syntax (make-id-stx orig-id)
+  (make-set!-transformer
+   (lambda (stx)
+     (syntax-case stx (set!)
+       [(set! id v) (raise-syntax-error #f
+                                        "assignment to self identifier disallowed"
+                                        stx)]
+       [(id arg ...) (quasisyntax/loc stx (#,orig-id arg ...))]
+       [id (datum->syntax orig-id (syntax-e orig-id) stx orig-id orig-id)]))))
+
+(define-syntax (add-method stx)
+  (syntax-case stx ()
+    [(_ whole-stx cls superclass-id m)
+     (let ([stx #'whole-stx])
+       (syntax-case #'m ()
+         [(kind result-type (id arg ...) body0 body ...)
+          (or (free-identifier=? #'kind #'+)
+              (free-identifier=? #'kind #'-))
+          (let ([id #'id]
+                [args (syntax->list #'(arg ...))]
+                [in-class? (free-identifier=? #'kind #'+)])
+            (when (null? args)
+              (unless (identifier? id)
+                (raise-syntax-error #f
+                                    "expected an identifier for method name"
+                                    stx
+                                    id)))
+            (with-syntax ([((arg-tag arg-type arg-id) ...)
+                           (if (null? args)
+                               null
+                               (parse-arg-list (cons id args) stx #t))])
+              (with-syntax ([id-str (if (null? args)
+                                        (symbol->string (syntax-e id))
+                                        (symbol->string (combine #'(arg-tag ...))))]
+                            [(dealloc-body ...)
+                             (if (eq? (syntax-e id) 'dealloc)
+                                 (syntax-case stx ()
+                                   [(_ _ _ [ivar ...] . _)
+                                    (with-syntax ([(ivar-str ...)
+                                                   (map (lambda (ivar)
+                                                          (symbol->string (syntax-e ivar)))
+                                                        (syntax->list #'(ivar ...)))])
+                                      #'((free-fields self '(ivar-str ...))
+                                         (super-tell #:type _void dealloc)))]
+                                   [_ (error "oops")])
+                                 '())]
+                            [in-cls (if in-class?
+                                        #'(object_getClass cls)
+                                        #'cls)])
+                (syntax/loc stx
+                  (let ([rt result-type]
+                        [arg-id arg-type] ...)
+                    (void (class_addMethod in-cls
+                                           (sel_registerName id-str)
+                                           (save-method!
+                                            (lambda (self-id cmd arg-id ...)
+                                              (syntax-parameterize ([self (make-id-stx #'self-id)]
+                                                                    [super-class (make-id-stx #'superclass-id)]
+                                                                    [super-tell do-super-tell])
+                                                body0 body ...
+                                                dealloc-body ...)))
+                                           (_fun _id _id arg-type ... -> rt)
+                                           (generate-layout rt (list arg-id ...)))))))))]
+         [else (raise-syntax-error #f
+                                   "bad method form"
+                                   stx
+                                   #'m)]))]))
+
+(define methods (make-hasheq))
+(define (save-method! m)
+  ;; Methods are never GCed, since classes are never unregistered
+  (hash-set! methods m #t)
+  m)
+
+(define (add-ivar cls name)
+  (void (class_addIvar cls
+                       (symbol->string name)
+                       (ctype-sizeof _pointer)
+                       (sub1 (integer-length (ctype-alignof _pointer)))
+                       (layout->string (ctype->layout _pointer)))))
+
+(define-for-syntax (do-super-tell stx)
+  (syntax-case stx ()
+    [(_ #:type t)
+     (raise-syntax-error #f
+                         "method name missing"
+                         stx)]
+    [(_ #:type t method)
+     (let ([m #'method])
+       (check-method-name m stx)
+       (quasisyntax/loc stx
+         ((objc_msgSendSuper/typed (type-vector t))
+          (make-objc_super self super-class) 
+          #,(register-selector (syntax-e m)))))]
+    [(_ method)
+     (not (keyword? (syntax-e #'method)))
+     (let ([m #'method])
+       (check-method-name m stx)
+       (quasisyntax/loc stx
+         ((objc_msgSendSuper/typed (type-vector _id)) 
+          (make-objc_super self super-class)
+          #,(register-selector (syntax-e m)))))]
+    [(_ #:type result-type method/arg ...)
+     (build-send stx #'result-type 
+                 #'objc_msgSendSuper/typed
+                 #'((make-objc_super self super-class))
+                 #'(method/arg ...))]
+    [(_ method/arg ...)
+     (build-send stx #'_id
+                 #'objc_msgSendSuper/typed
+                 #'((make-objc_super self super-class))
+                 #'(method/arg ...))]))
diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss
index 8c7ccf7610..fa2520d35e 100644
--- a/collects/mzlib/foreign.ss
+++ b/collects/mzlib/foreign.ss
@@ -58,7 +58,7 @@
           (unsafe malloc) (unsafe free) (unsafe end-stubborn-change)
           cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
           ptr-offset ptr-add! offset-ptr? set-ptr-offset!
-          ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string)
+          ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout
           _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
           _fixint _ufixint _fixnum _ufixnum
           _float _double _double*
@@ -1494,13 +1494,33 @@
                     (if v (apply values v) (msg/fail-thunk))))]
             [else (msg/fail-thunk)]))))
 
+;; ----------------------------------------------------------------------------
+;;
+
+(define prim-synonyms
+  #hasheq((double* . double)
+          (fixint . long)
+          (ufixint . ulong)
+          (fixnum . long)
+          (ufixnum . ulong)
+          (path . bytes)
+          (symbol . bytes)
+          (scheme . pointer)))
+
+(define (ctype->layout c)
+  (let ([b (ctype-basetype c)])
+    (cond
+     [(ctype? b) (ctype->layout b)]
+     [(list? b) (map ctype->layout b)]
+     [else (hash-ref prim-synonyms b b)])))
+
 ;; ----------------------------------------------------------------------------
 ;; Misc utilities
 
 ;; Used by set-ffi-obj! to get the actual value so it can be kept around
 (define (get-lowlevel-object x type)
   (let ([basetype (ctype-basetype type)])
-    (if basetype
+    (if (ctype? basetype)
       (let ([s->c (ctype-scheme->c type)])
         (get-lowlevel-object (if s->c (s->c x) x) basetype))
       (values x type))))
diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss
index c0fa768946..12fc3fd4b8 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "17dec2008")
+#lang scheme/base (provide stamp) (define stamp "18dec2008")
diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss
index cb8d297294..d610c5ced9 100644
--- a/collects/scheme/sandbox.ss
+++ b/collects/scheme/sandbox.ss
@@ -25,11 +25,13 @@
          sandbox-make-logger
          sandbox-memory-limit
          sandbox-eval-limits
+         sandbox-eval-handlers
          call-with-trusted-sandbox-configuration
          evaluator-alive?
          kill-evaluator
          break-evaluator
          set-eval-limits
+         set-eval-handler
          put-input
          get-output
          get-error-output
@@ -40,6 +42,8 @@
          call-in-nested-thread*
          call-with-limits
          with-limits
+         call-with-custodian-shutdown
+         call-with-killing-threads
          exn:fail:sandbox-terminated?
          exn:fail:sandbox-terminated-reason
          exn:fail:resource?
@@ -73,7 +77,8 @@
                  [sandbox-make-code-inspector current-code-inspector]
                  [sandbox-make-logger         current-logger]
                  [sandbox-memory-limit        #f]
-                 [sandbox-eval-limits         #f])
+                 [sandbox-eval-limits         #f]
+                 [sandbox-eval-handlers       '(#f #f)])
     (thunk)))
 
 (define sandbox-namespace-specs
@@ -306,6 +311,17 @@
                      (set! p (current-preserved-thread-cell-values))))))))
           (lambda () (when p (current-preserved-thread-cell-values p))))))))
 
+;; useful wrapper around the above: run thunk, return one of:
+;; - (list values val ...)
+;; - (list raise exn)
+;; - 'kill or 'shut
+(define (nested thunk)
+  (call-in-nested-thread*
+   (lambda ()
+     (with-handlers ([void (lambda (e) (list raise e))])
+       (call-with-values thunk (lambda vs (list* values vs)))))
+   (lambda () 'kill) (lambda () 'shut)))
+
 (define (call-with-limits sec mb thunk)
   ;; note that when the thread is killed after using too much memory or time,
   ;; then all thread-local changes (parameters and thread cells) are discarded
@@ -319,33 +335,25 @@
            c (inexact->exact (round (* mb 1024 1024))) c)
           (values c (make-custodian-box c #t)))
         (values (current-custodian) #f)))
-    (parameterize ([current-custodian cust])
-      (call-in-nested-thread*
-       (lambda ()
-         ;; time limit
-         (when sec
-           (let ([t (current-thread)])
-             (thread (lambda ()
-                       (unless (sync/timeout sec t) (set! r 'time))
-                       (kill-thread t)))))
-         (set! r (with-handlers ([void (lambda (e) (list raise e))])
-                   (call-with-values thunk (lambda vs (list* values vs))))))
-       ;; The thread might be killed by the timer thread, so don't let
-       ;; call-in-nested-thread* kill it -- if user code did so, then just
-       ;; register the request and kill it below.  Do this for a
-       ;; custodian-shutdown to, just in case.
-       (lambda ()
-         (unless r (set! r 'kill))
-         ;; (kill-thread (current-thread))
-         )
-       (lambda ()
-         (unless r (set! r 'shut))
-         ;; (custodian-shutdown-all (current-custodian))
-         )))
-    (when (and cust-box (not (custodian-box-value cust-box)))
-      (if (memq r '(kill shut)) ; should always be 'shut
-        (set! r 'memory)
-        (format "cust died with: ~a" r))) ; throw internal error below
+    (define timeout? #f)
+    (define r
+      (parameterize ([current-custodian cust])
+        (if sec
+          (nested
+           (lambda ()
+             ;; time limit
+             (when sec
+               (let ([t (current-thread)])
+                 (thread (lambda ()
+                           (unless (sync/timeout sec t) (set! timeout? #t))
+                           (kill-thread t)))))
+             (thunk)))
+          (nested thunk))))
+    (cond [timeout? (set! r 'time)]
+          [(and cust-box (not (custodian-box-value cust-box)))
+           (if (memq r '(kill shut)) ; should always be 'shut
+             (set! r 'memory)
+             (format "cust died with: ~a" r))]) ; throw internal error below
     (case r
       [(kill) (kill-thread (current-thread))]
       [(shut) (custodian-shutdown-all (current-custodian))]
@@ -362,6 +370,30 @@
     [(with-limits sec mb body ...)
      (call-with-limits sec mb (lambda () body ...))]))
 
+;; other resource utilities
+
+(define (call-with-custodian-shutdown thunk)
+  (let* ([cust (make-custodian (current-custodian))]
+         [r (parameterize ([current-custodian cust]) (nested thunk))])
+    (case r
+      [(kill) (kill-thread (current-thread))]
+      [(shut) (custodian-shutdown-all (current-custodian))]
+      [else (apply (car r) (cdr r))])))
+
+(define (call-with-killing-threads thunk)
+  (let* ([cur (current-custodian)] [sub (make-custodian cur)])
+    (define r (parameterize ([current-custodian sub]) (nested thunk)))
+    (let kill-all ([x sub])
+      (cond [(custodian? x) (for-each kill-all (custodian-managed-list x cur))]
+            [(thread? x) (kill-thread x)]))
+    (case r
+      [(kill) (kill-thread (current-thread))]
+      [(shut) (custodian-shutdown-all (current-custodian))]
+      [else (apply (car r) (cdr r))])))
+
+(define sandbox-eval-handlers
+  (make-parameter (list #f call-with-custodian-shutdown)))
+
 ;; Execution ----------------------------------------------------------------
 
 (define (literal-identifier=? x y)
@@ -555,12 +587,14 @@
 (define-evaluator-messenger kill-evaluator 'kill)
 (define-evaluator-messenger break-evaluator 'break)
 (define-evaluator-messenger (set-eval-limits secs mb) 'limits)
+(define-evaluator-messenger (set-eval-handler handler) 'handler)
 (define-evaluator-messenger (put-input . xs) 'input)
 (define-evaluator-messenger get-output 'output)
 (define-evaluator-messenger get-error-output 'error-output)
 (define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered)
-(define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk)
-
+(define (call-in-sandbox-context evaluator thunk [unrestricted? #f])
+  (evaluator (make-evaluator-message (if unrestricted? 'thunk* 'thunk)
+                                     (list thunk))))
 
 (define-struct (exn:fail:sandbox-terminated exn:fail) (reason) #:transparent)
 (define (make-terminated reason)
@@ -585,13 +619,18 @@
   (define output        #f)
   (define error-output  #f)
   (define limits        (sandbox-eval-limits))
+  (define eval-handler  (car (sandbox-eval-handlers))) ; 1st handler on startup
   (define user-thread   #t) ; set later to the thread
   (define user-done-evt #t) ; set in the same place
   (define terminated?   #f) ; set to an exception value when the sandbox dies
   (define (limit-thunk thunk)
     (let* ([sec (and limits (car limits))]
-           [mb  (and limits (cadr limits))])
-      (if (or sec mb) (lambda () (call-with-limits sec mb thunk)) thunk)))
+           [mb  (and limits (cadr limits))]
+           [thunk (if (or sec mb)
+                    (lambda () (call-with-limits sec mb thunk))
+                    thunk)]
+           [thunk (if eval-handler (lambda () (eval-handler thunk)) thunk)])
+      thunk))
   (define (terminated! reason)
     (unless terminated?
       (set! terminated?
@@ -632,6 +671,7 @@
        limit-thunk
        (and coverage? (lambda (es+get) (set! uncovered es+get))))
       (channel-put result-ch 'ok))
+    (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler
     ;; finally wait for interaction expressions
     (let ([n 0])
       (let loop ()
@@ -641,11 +681,12 @@
           (with-handlers ([void (lambda (exn)
                                   (channel-put result-ch (cons 'exn exn)))])
             (define run
-              (limit-thunk (if (evaluator-message? expr)
-                             (lambda ()
-                               (apply (evaluator-message-msg expr)
-                                      (evaluator-message-args expr)))
-                             (lambda ()
+              (if (evaluator-message? expr)
+                (case (evaluator-message-msg expr)
+                  [(thunk) (limit-thunk (car (evaluator-message-args expr)))]
+                  [(thunk*) (car (evaluator-message-args expr))]
+                  [else (error 'sandbox "internal error (bad message)")])
+                (limit-thunk (lambda ()
                                (set! n (add1 n))
                                (eval* (input->code (list expr) 'eval n))))))
             (channel-put result-ch (cons 'vals (call-with-values run list))))
@@ -682,7 +723,7 @@
             (filter (lambda (x) (equal? src (syntax-source x))) uncovered)
             uncovered))]))
   (define (output-getter p)
-    (if (procedure? p) (user-eval (make-evaluator-message p '())) p))
+    (if (procedure? p) (user-eval (make-evaluator-message 'thunk (list p))) p))
   (define input-putter
     (case-lambda
      [() (input-putter input)]
@@ -696,16 +737,16 @@
     (if (evaluator-message? expr)
       (let ([msg (evaluator-message-msg expr)])
         (case msg
-          [(alive?) (and user-thread (not (thread-dead? user-thread)))]
-          [(kill)   (terminate+kill! 'evaluator-killed #f)]
-          [(break)  (user-break)]
-          [(limits) (set! limits (evaluator-message-args expr))]
-          [(input)  (apply input-putter (evaluator-message-args expr))]
-          [(output) (output-getter output)]
+          [(alive?)  (and user-thread (not (thread-dead? user-thread)))]
+          [(kill)    (terminate+kill! 'evaluator-killed #f)]
+          [(break)   (user-break)]
+          [(limits)  (set! limits (evaluator-message-args expr))]
+          [(handler) (set! eval-handler (car (evaluator-message-args expr)))]
+          [(input)   (apply input-putter (evaluator-message-args expr))]
+          [(output)  (output-getter output)]
           [(error-output) (output-getter error-output)]
           [(uncovered) (apply get-uncovered (evaluator-message-args expr))]
-          [(thunk)  (user-eval (make-evaluator-message
-                                (car (evaluator-message-args expr)) '()))]
+          [(thunk thunk*) (user-eval expr)]
           [else (error 'evaluator "internal error, bad message: ~e" msg)]))
       (user-eval expr)))
   (define (make-output what out set-out! allow-link?)
diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl
index d9cdf24faf..064b494d7f 100644
--- a/collects/scribblings/foreign/types.scrbl
+++ b/collects/scribblings/foreign/types.scrbl
@@ -13,16 +13,18 @@ along with conversion functions to and from the existing types.
 
 @; ----------------------------------------------------------------------
 
-@section{Type Constructors}
+@section[#:tag "ctype"]{Type Constructors}
 
 @defproc[(make-ctype [type ctype?]
                      [scheme-to-c (or/c #f (any/c . -> . any))]
                      [c-to-scheme (or/c #f (any/c . -> . any))])
          ctype?]{
 
-Creates a new @tech{C type} value, with the given conversions
-functions.  The conversion functions can be @scheme[#f] meaning that
-there is no conversion for the corresponding direction.  If both
+Creates a new @tech{C type} value whose representation for foreign
+code is the same as @scheme[type]'s. The given conversions functions
+convert to and from the Scheme representation of @scheme[type]. Either
+conversion function can be @scheme[#f], meaning that the conversion
+for the corresponding direction is the identity function.  If both
 functions are @scheme[#f], @scheme[type] is returned.}
 
 
@@ -33,12 +35,29 @@ otherwise.}
 
 
 @defproc*[([(ctype-sizeof [type ctype?]) exact-nonnegative-integer?]
-           [(ctype-alignof [ctype ctype?]) exact-nonnegative-integer?])]{
+           [(ctype-alignof [type ctype?]) exact-nonnegative-integer?])]{
 
 Returns the size or alignment of a given @scheme[type] for the current
 platform.}
 
 
+@defproc[(ctype->layout [type ctype?]) (flat-rec-contract rep
+                                         symbol?
+                                         (listof rep))]{
+
+Returns a value to describe the eventual C representation of the
+type. It can be any of the following symbols:
+
+@schemeblock[
+  'int8 'uint8 'int16 'uint16 'int32 'uint32 'int64 'uint64
+  'float 'double 'bool 'void 'pointer 'fpointer 
+  'bytes 'string/ucs-4 'string/utf-16
+]
+
+The result can also be a list, which describes a C struct whose
+element representations are provided in order within the list.}
+
+
 @defproc[(compiler-sizeof [sym symbol?]) exact-nonnegative-integer?]{
 
 Possible values for @scheme[symbol] are @scheme['int], @scheme['char],
@@ -338,7 +357,7 @@ values: @itemize[
   the callback value will be stored in the box, overriding any value
   that was in the box (making it useful for holding a single callback
   value).  When you know that it is no longer needed, you can
-  `release' the callback value by changing the box contents, or by
+  ``release'' the callback value by changing the box contents, or by
   allowing the box itself to be garbage-collected.  This is can be
   useful if the box is held for a dynamic extent that corresponds to
   when the callback is needed; for example, you might encapsulate some
@@ -400,7 +419,7 @@ used to access the actual foreign return value.
 
 In rare cases where complete control over the input arguments is needed, the
 wrapper's argument list can be specified as @scheme[args], in any form (including
-a `rest' argument).  Identifiers in this place are related to type labels, so
+a ``rest'' argument).  Identifiers in this place are related to type labels, so
 if an argument is there is no need to use an expression.
 
 For example,
@@ -746,7 +765,7 @@ than the struct itself.  The following works as expected:
 
 As described above, @scheme[_list-struct]s should be used in cases where
 efficiency is not an issue.  We continue using @scheme[define-cstruct], first
-define a type for @cpp{A} which makes it possible to use `@cpp{makeA}:
+define a type for @cpp{A} which makes it possible to use @cpp{makeA}:
 
 @schemeblock[
 (define-cstruct #,(schemeidfont "_A") ([x _int] [y _byte]))
@@ -785,7 +804,7 @@ We can access all values of @scheme[b] using a naive approach:
 ]
 
 but this is inefficient as it allocates and copies an instance of
-`@cpp{A}' on every access.  Inspecting the tags @scheme[(cpointer-tag
+@cpp{A} on every access.  Inspecting the tags @scheme[(cpointer-tag
 b)] we can see that @cpp{A}'s tag is included, so we can simply use
 its accessors and mutators, as well as any function that is defined to
 take an @cpp{A} pointer:
diff --git a/collects/scribblings/foreign/unexported.scrbl b/collects/scribblings/foreign/unexported.scrbl
index 10d2189c01..a4631b9343 100644
--- a/collects/scribblings/foreign/unexported.scrbl
+++ b/collects/scribblings/foreign/unexported.scrbl
@@ -39,8 +39,9 @@ These values can also be used as C pointer objects.}
            [(ctype-c->scheme [type ctype?]) procedure?])]{
 
 Accessors for the components of a C type object, made by
-@scheme[make-ctype].  The @scheme[ctype-basetype] selector returns
-@scheme[#f] for primitive types (including cstruct types).}
+@scheme[make-ctype].  The @scheme[ctype-basetype] selector returns a
+symbol for primitive types that names the type, a list of ctypes for
+cstructs, and another ctype for user-defined ctypes.}
 
 
 @defproc[(ffi-call [ptr any/c] [in-types (listof ctype?)] [out-type ctype?]
diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl
index a9ef74c6a3..f1787d395f 100644
--- a/collects/scribblings/reference/sandbox.scrbl
+++ b/collects/scribblings/reference/sandbox.scrbl
@@ -629,6 +629,24 @@ then, assuming sufficiently small limits,
 ]}
 
 
+@defparam[sandbox-eval-handlers handlers
+          (list/c (or/c #f ((-> any) . -> . any))
+                  (or/c #f ((-> any) . -> . any)))]{
+
+A parameter that determines two (optional) handlers that wrap
+sandboxed evaluations.  The first one is used when evaluating the
+initial program when the sandbox is being set-up, and the second is
+used for each interaction.  Each of these handlers should expect a
+thunk as an argument, and they should execute these thunks ---
+possibly imposing further restrictions.  The default values are
+@scheme[#f] and @scheme[call-with-custodian-shutdown], meaning no
+additional restrictions on initial sandbox code (e.g., it can start
+background threads), and a custodian-shutdown around each interaction
+that follows.  Another useful function for this is
+@scheme[call-with-killing-threads] which kills all threads, but leaves
+other resources intact.}
+
+
 @defparam[sandbox-make-inspector make (-> inspector?)]{
 
 A parameter that determines the procedure used to create the inspector
@@ -691,7 +709,8 @@ propagates the break to the evaluator's context.}
 
 @defproc[(set-eval-limits [evaluator (any/c . -> . any)]
                           [secs (or/c exact-nonnegative-integer? #f)]
-                          [mb (or/c exact-nonnegative-integer? #f)]) void?]{
+                          [mb (or/c exact-nonnegative-integer? #f)])
+         void?]{
 
 Changes the per-expression limits that @scheme[evaluator] uses to
 @scheme[sec] seconds and @scheme[mb] megabytes (either one can be
@@ -702,6 +721,33 @@ because changing the @scheme[sandbox-eval-limits] parameter does not
 affect existing evaluators. See also @scheme[call-with-limits].}
 
 
+@defproc[(set-eval-handler [evaluator (any/c . -> . any)]
+                           [handler (or/c #f ((-> any) . -> . any))])
+         void?]{
+
+Changes the per-expression handler that the @scheme[evaluator] uses
+around each interaction.  A @scheme[#f] value means no handler is
+used.
+
+This procedure should be used to modify an existing evaluator handler,
+because changing the @scheme[sandbox-eval-handlers] parameter does not
+affect existing evaluators. See also
+@scheme[call-with-custodian-shutdown] and
+@scheme[call-with-killing-threads] for two useful handlers that are
+provided.}
+
+
+@defproc*[([(call-with-custodian-shutdown [thunk (-> any)]) any]
+           [(call-with-killing-threads [thunk (-> any)]) any])]{
+
+These functions are useful for use as an evaluation handler.
+@scheme[call-with-custodian-shutdown] will execute the @scheme[thunk]
+in a fresh custodian, then shutdown that custodian, making sure that
+@scheme[thunk] could not have left behind any resources.
+@scheme[call-with-killing-threads] is similar, except that it kills
+threads that were left, but leaves other resources as is.}
+
+
 @defproc*[([(put-input [evaluator (any/c . -> . any)]) output-port?]
            [(put-input [evaluator (any/c . -> . any)]
                        [i/o (or/c bytes? string? eof-object?)]) void?])]{
@@ -779,12 +825,14 @@ coverage results, since each expression may be assigned a single
 source location.}
 
 @defproc[(call-in-sandbox-context [evaluator (any/c . -> . any)]
-                                  [thunk (-> any)])
+                                  [thunk (-> any)]
+                                  [unrestricted? boolean? #f])
          any]{
 
 Calls the given @scheme[thunk] in the context of a sandboxed
-evaluator.  The call is performed under the resource limits that are
-used for evaluating expressions.
+evaluator.  The call is performed under the resource limits and
+evaluation handler that are used for evaluating expressions, unless
+@scheme[unrestricted?] is specified as true.
 
 This is usually similar to @scheme[(evaluator (list thunk))], except
 that this relies on the common meaning of list expressions as function
diff --git a/collects/scribblings/reference/security-guards.scrbl b/collects/scribblings/reference/security-guards.scrbl
index 9296307650..164a437cd9 100644
--- a/collects/scribblings/reference/security-guards.scrbl
+++ b/collects/scribblings/reference/security-guards.scrbl
@@ -37,8 +37,8 @@ host platform.
                                               (or/c (integer-in 1 65535) #f)
                                               (or/c 'server 'client)
                                               . -> . any)]
-                              [link (or/c (symbol? path? path? . -> . any) #f)
-                                    #f])
+                              [link-guard (or/c (symbol? path? path? . -> . any) #f)
+                                          #f])
           security-guard?]{
 
 Creates a new security guard as child of @scheme[parent].
diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c
index 3a7628ca28..0518cd0397 100644
--- a/src/foreign/foreign.c
+++ b/src/foreign/foreign.c
@@ -810,9 +810,16 @@ typedef union _ForeignAny {
 /* Type objects */
 
 /* This struct is used for both user types and primitive types (including
- * struct types).  If it is a primitive type then basetype will be NULL, and
+ * struct types).  If it is a user type then basetype will be another ctype,
+ * otherwise,
+ * - if it's a primitive type, then basetype will be a symbol naming that type
+ * - if it's a struct, then basetype will be the list of ctypes that
+ *   made this struct
  * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
- * integer (a label value) for non-struct type. */
+ * integer (a label value) for non-struct type.  (Note that the
+ * integer is not really needed, since it is possible to identify the
+ * type by the basetype field.)
+ */
 /* ctype structure definition */
 static Scheme_Type ctype_tag;
 typedef struct ctype_struct {
@@ -849,8 +856,8 @@ END_XFORM_SKIP;
 #endif
 
 #define CTYPE_BASETYPE(x)  (((ctype_struct*)(x))->basetype)
-#define CTYPE_PRIMP(x)     (NULL == (CTYPE_BASETYPE(x)))
-#define CTYPE_USERP(x)     (!(CTYPE_PRIMP(x)))
+#define CTYPE_USERP(x)     (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
+#define CTYPE_PRIMP(x)     (!CTYPE_USERP(x))
 #define CTYPE_PRIMTYPE(x)  ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
 #define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
 #define CTYPE_USER_S2C(x)  (((ctype_struct*)(x))->scheme_to_c)
@@ -861,12 +868,9 @@ END_XFORM_SKIP;
 #define MYNAME "ctype-basetype"
 static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[])
 {
-  Scheme_Object *base;
   if (!SCHEME_CTYPEP(argv[0]))
     scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
-  base = CTYPE_BASETYPE(argv[0]);
-  if (NULL == base) return scheme_false;
-  else              return base;
+  return CTYPE_BASETYPE(argv[0]);
 }
 
 #undef MYNAME
@@ -1046,7 +1050,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
     scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
   type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   type->so.type = ctype_tag;
-  type->basetype = (NULL);
+  type->basetype = (argv[0]);
   type->scheme_to_c = ((Scheme_Object*)libffi_type);
   type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
   scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
@@ -1166,12 +1170,11 @@ END_XFORM_SKIP;
 static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
                                int delta, int args_loc)
 {
-  Scheme_Object *res, *base;
+  Scheme_Object *res;
   if (!SCHEME_CTYPEP(type))
     scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
-  base = CTYPE_BASETYPE(type);
-  if (base != NULL) {
-    res = C2SCHEME(base, src, delta, args_loc);
+  if (CTYPE_USERP(type)) {
+    res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
     if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
       return res;
     else
@@ -1219,13 +1222,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
  * is used for both the function definition and calls, but the actual code in
  * the function is different: in the relevant cases zero an int and offset the
  * ptr */
-#ifdef SCHEME_BIG_ENDIAN
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
-#else
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset)
-#endif
 
 /* Usually writes the C object to dst and returns NULL.  When basetype_p is not
  * NULL, then any pointer value (any pointer or a struct) is returned, and the
@@ -1254,7 +1250,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
          scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
   } else switch (CTYPE_PRIMLABEL(type)) {
     case FOREIGN_void:
-      scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      break;
     case FOREIGN_int8:
 #ifdef SCHEME_BIG_ENDIAN
       if (sizeof(Tsint8)<sizeof(int) && ret_loc) {
@@ -1597,7 +1594,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         return NULL; /* hush the compiler */
       }
     case FOREIGN_fpointer:
-      scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      break;
     case FOREIGN_struct:
       if (!SCHEME_FFIANYPTRP(val))
         scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
@@ -2347,7 +2345,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
     offset = 0;
     p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
                  &offset, 0);
-    if (p != NULL) {
+    if ((p != NULL) || offset) {
       avalues[i] = p;
       ivals[i].x_fixnum = basetype; /* remember the base type */
     } else {
@@ -2370,7 +2368,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
   /* We finished with all possible mallocs, clear up the avalues and offsets
    * mess */
   for (i=0; i<nargs; i++) {
-    if (avalues[i] == NULL)     /* if this was a non-pointer... */
+    if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
       avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
     else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
       /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
@@ -2625,6 +2623,28 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
   return (Scheme_Object*)data;
 }
 
+/*****************************************************************************/
+
+void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
+{
+  char *str;
+  if (!SCHEME_CTYPEP(ctype))
+    scheme_wrong_type("Scheme->C", "C-type", 0, 1, &ctype);
+  if (CTYPE_PRIMP(ctype)) {
+    scheme_print_bytes(pp, "#<ctype:", 0, 8);
+    ctype = CTYPE_BASETYPE(ctype);
+    if (SCHEME_SYMBOLP(ctype)) {
+      str = SCHEME_SYM_VAL(ctype);
+      scheme_print_bytes(pp, str, 0, strlen(str));
+    } else {
+      scheme_print_bytes(pp, "cstruct", 0, 7);
+    }
+    scheme_print_bytes(pp, ">", 0, 1);
+  } else {
+    scheme_print_bytes(pp, "#<ctype>", 0, 8);
+  }
+}
+
 /*****************************************************************************/
 /* Initialization */
 
@@ -2632,6 +2652,7 @@ void scheme_init_foreign(Scheme_Env *env)
 {
   Scheme_Env *menv;
   ctype_struct *t;
+  Scheme_Object *s;
   menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
   ffi_lib_tag = scheme_make_type("<ffi-lib>");
   ffi_obj_tag = scheme_make_type("<ffi-obj>");
@@ -2643,6 +2664,7 @@ void scheme_init_foreign(Scheme_Env *env)
   GC_register_traversers(ctype_tag, ctype_SIZE, ctype_MARK, ctype_FIXUP, 1, 0);
   GC_register_traversers(ffi_callback_tag, ffi_callback_SIZE, ffi_callback_MARK, ffi_callback_FIXUP, 1, 0);
 #endif
+  scheme_set_type_printer(ctype_tag, ctype_printer);
   MZ_REGISTER_STATIC(opened_libs);
   opened_libs = scheme_make_hash_table(SCHEME_hash_string);
   MZ_REGISTER_STATIC(default_sym);
@@ -2749,153 +2771,178 @@ void scheme_init_foreign(Scheme_Env *env)
     scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
   scheme_add_global("ffi-callback",
     scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv);
+  s = scheme_intern_symbol("void");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_void);
   scheme_add_global("_void", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("int8");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8);
   scheme_add_global("_int8", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("uint8");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8);
   scheme_add_global("_uint8", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("int16");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16);
   scheme_add_global("_int16", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("uint16");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16);
   scheme_add_global("_uint16", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("int32");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32);
   scheme_add_global("_int32", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("uint32");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32);
   scheme_add_global("_uint32", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("int64");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64);
   scheme_add_global("_int64", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("uint64");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64);
   scheme_add_global("_uint64", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("fixint");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint);
   scheme_add_global("_fixint", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("ufixint");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint);
   scheme_add_global("_ufixint", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("fixnum");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum);
   scheme_add_global("_fixnum", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("ufixnum");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum);
   scheme_add_global("_ufixnum", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("float");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_float);
   scheme_add_global("_float", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("double");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
   scheme_add_global("_double", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("double*");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS);
   scheme_add_global("_double*", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("bool");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool);
   scheme_add_global("_bool", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("string/ucs-4");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
   scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("string/utf-16");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
   scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("bytes");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
   scheme_add_global("_bytes", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("path");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
   scheme_add_global("_path", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("symbol");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol);
   scheme_add_global("_symbol", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("pointer");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
   scheme_add_global("_pointer", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("scheme");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
   scheme_add_global("_scheme", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("fpointer");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
-  t->basetype = (NULL);
+  t->basetype = (s);
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
   scheme_add_global("_fpointer", (Scheme_Object*)t, menv);
diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc
index dd544ad838..fc8193244b 100755
--- a/src/foreign/foreign.ssc
+++ b/src/foreign/foreign.ssc
@@ -10,6 +10,8 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0"
  ** to make changes, edit that file and
  ** run it to generate an updated version
  ** of this file.
+ ** NOTE: This is no longer true, foreign.ssc needs to be updated to work with
+ ** the scribble/text preprocessor instead.
  ********************************************/
 
 {:(load "ssc-utils.ss"):}
@@ -445,7 +447,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
 
 (define *type-counter* 0)
 
-(define (describe-type stype cname ftype ctype pred s->c c->s offset)
+(define (describe-type type stype cname ftype ctype pred s->c c->s offset)
   (set! *type-counter* (add1 *type-counter*))
   (~ "#define FOREIGN_"cname" ("*type-counter*")" \\
      "/* Type Name:   "stype (and (not (equal? cname stype))
@@ -466,7 +468,10 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
      " * C->Scheme:   "(cond [(not c->s) "-none-"]
                              [(procedure? c->s) (c->s "<C>")]
                              [else (list c->s"(<C>)")]) \\
-     " */" \\))
+     " */" \\
+     ;; no need for these, at least for now:
+     ;; "static Scheme_Object *"cname"_sym;"\\
+     ))
 
 (define (make-ctype type args)
   (define (prop p . default)
@@ -491,7 +496,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
          [s->c  (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))]
          [c->s  (prop 'c->s)]
          [offset (prop 'offset #f)])
-    (describe-type stype cname ftype ctype pred s->c c->s offset)
+    (describe-type type stype cname ftype ctype pred s->c c->s offset)
     `(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
       (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset))))
 
@@ -726,17 +731,24 @@ typedef union _ForeignAny {
 /* Type objects */
 
 /* This struct is used for both user types and primitive types (including
- * struct types).  If it is a primitive type then basetype will be NULL, and
+ * struct types).  If it is a user type then basetype will be another ctype,
+ * otherwise,
+ * - if it's a primitive type, then basetype will be a symbol naming that type
+ * - if it's a struct, then basetype will be the list of ctypes that
+ *   made this struct
  * scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
- * integer (a label value) for non-struct type. */
+ * integer (a label value) for non-struct type.  (Note that the
+ * integer is not really needed, since it is possible to identify the
+ * type by the basetype field.)
+ */
 {:(cdefstruct ctype
     (basetype    "Scheme_Object*")
     (scheme_to_c "Scheme_Object*")
     (c_to_scheme "Scheme_Object*")):}
 
 #define CTYPE_BASETYPE(x)  (((ctype_struct*)(x))->basetype)
-#define CTYPE_PRIMP(x)     (NULL == (CTYPE_BASETYPE(x)))
-#define CTYPE_USERP(x)     (!(CTYPE_PRIMP(x)))
+#define CTYPE_USERP(x)     (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
+#define CTYPE_PRIMP(x)     (!CTYPE_USERP(x))
 #define CTYPE_PRIMTYPE(x)  ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
 #define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
 #define CTYPE_USER_S2C(x)  (((ctype_struct*)(x))->scheme_to_c)
@@ -745,12 +757,9 @@ typedef union _ForeignAny {
 /* Returns #f for primitive types. */
 {:(cdefine ctype-basetype 1):}
 {
-  Scheme_Object *base;
   if (!SCHEME_CTYPEP(argv[0]))
     scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
-  base = CTYPE_BASETYPE(argv[0]);
-  if (NULL == base) return scheme_false;
-  else              return base;
+  return CTYPE_BASETYPE(argv[0]);
 }
 
 {:(cdefine ctype-scheme->c 1):}
@@ -892,7 +901,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
   dummy = &libffi_type;
   if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK)
     scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
-  {:(cmake-object "type" ctype "NULL"
+  {:(cmake-object "type" ctype "argv[0]"
                   "(Scheme_Object*)libffi_type"
                   "(Scheme_Object*)FOREIGN_struct"):}
   scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
@@ -974,12 +983,11 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
 static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
                                int delta, int args_loc)
 {
-  Scheme_Object *res, *base;
+  Scheme_Object *res;
   if (!SCHEME_CTYPEP(type))
     scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
-  base = CTYPE_BASETYPE(type);
-  if (base != NULL) {
-    res = C2SCHEME(base, src, delta, args_loc);
+  if (CTYPE_USERP(type)) {
+    res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
     if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
       return res;
     else
@@ -1008,13 +1016,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
  * is used for both the function definition and calls, but the actual code in
  * the function is different: in the relevant cases zero an int and offset the
  * ptr */
-#ifdef SCHEME_BIG_ENDIAN
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
-#else
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset)
-#endif
 
 /* Usually writes the C object to dst and returns NULL.  When basetype_p is not
  * NULL, then any pointer value (any pointer or a struct) is returned, and the
@@ -1091,7 +1092,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
                 (error 'scheme->c "unhandled pointer type: ~s" ctype)
                 (~ "  if (!("(pred "val" x)")) "(wrong-type "val" stype) \\
                    "  return NULL;"))))
-          (~ "  "(wrong-type "type" "non-void-C-type")))):}
+          (~ "  if (!ret_loc) "(wrong-type "type" "non-void-C-type")
+             ~ "  break;"))):}
     case FOREIGN_struct:
       if (!SCHEME_FFIANYPTRP(val))
         scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
@@ -1677,6 +1679,9 @@ static Scheme_Object *do_memop(const char *who, int mode,
                                        len, 0);
 }
 
+/* *** Calling Scheme code while the GC is working leads to subtle bugs, so
+   *** this is implemented now in Scheme using will executors. */
+
 /* internal: apply Scheme finalizer */
 void do_scm_finalizer(void *p, void *finalizer)
 {
@@ -1707,9 +1712,6 @@ void do_ptr_finalizer(void *p, void *finalizer)
 /* (Only needed in cases where pointer aliases might be created.) */
 /*
 
-  *** Calling Scheme code while the GC is working leads to subtle bugs, so
-  *** this is implemented now in Scheme using will executors.
-
 {:"(defsymbols pointer)":}
 {:"(cdefine register-finalizer 2 3)":}
 {
@@ -1789,7 +1791,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
     offset = 0;
     p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
                  &offset, 0);
-    if (p != NULL) {
+    if ((p != NULL) || offset) {
       avalues[i] = p;
       ivals[i].x_fixnum = basetype; /* remember the base type */
     } else {
@@ -1812,7 +1814,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
   /* We finished with all possible mallocs, clear up the avalues and offsets
    * mess */
   for (i=0; i<nargs; i++) {
-    if (avalues[i] == NULL)     /* if this was a non-pointer... */
+    if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
       avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
     else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
       /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
@@ -1961,7 +1963,7 @@ typedef struct closure_and_cif_struct {
 void free_cl_cif_args(void *ignored, void *p)
 {
   /*
-  scheme_warning("Releaseing cl+cif+args %V %V (%d)",
+  scheme_warning("Releasing cl+cif+args %V %V (%d)",
                  ignored,
                  (((closure_and_cif*)p)->data),
                  SAME_OBJ(ignored,(((closure_and_cif*)p)->data)));
@@ -2059,6 +2061,28 @@ void free_cl_cif_args(void *ignored, void *p)
   return (Scheme_Object*)data;
 }
 
+/*****************************************************************************/
+
+void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
+{
+  char *str;
+  if (!SCHEME_CTYPEP(ctype))
+    scheme_wrong_type("Scheme->C", "C-type", 0, 1, &ctype);
+  if (CTYPE_PRIMP(ctype)) {
+    scheme_print_bytes(pp, "#<ctype:", 0, 8);
+    ctype = CTYPE_BASETYPE(ctype);
+    if (SCHEME_SYMBOLP(ctype)) {
+      str = SCHEME_SYM_VAL(ctype);
+      scheme_print_bytes(pp, str, 0, strlen(str));
+    } else {
+      scheme_print_bytes(pp, "cstruct", 0, 7);
+    }
+    scheme_print_bytes(pp, ">", 0, 1);
+  } else {
+    scheme_print_bytes(pp, "#<ctype>", 0, 8);
+  }
+}
+
 /*****************************************************************************/
 /* Initialization */
 
@@ -2066,6 +2090,7 @@ void scheme_init_foreign(Scheme_Env *env)
 {
   Scheme_Env *menv;
   ctype_struct *t;
+  Scheme_Object *s;
   menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
   {:(for-each (lambda (x)
                 (~ (cadr x)"_tag = scheme_make_type(\"<"(car x)">\");"))
@@ -2076,6 +2101,7 @@ void scheme_init_foreign(Scheme_Env *env)
                    (cadr x)"_MARK, " (cadr x)"_FIXUP, 1, 0);"))
               (reverse cstructs)):}
 #endif
+  scheme_set_type_printer(ctype_tag, ctype_printer);
   MZ_REGISTER_STATIC(opened_libs);
   opened_libs = scheme_make_hash_table(SCHEME_hash_string);
   {:(for-each
@@ -2090,7 +2116,11 @@ void scheme_init_foreign(Scheme_Env *env)
                 (cadr x)", \""(car x)"\", "(caddr x)", "(cadddr x)"), menv);"))
       (reverse! cfunctions))
     (for-each-type
-      (cmake-object "t" ctype "NULL"
+      ;; no need for these, at least for now:
+      ;; (~ "MZ_REGISTER_STATIC("cname"_sym);" \\
+      ;;    cname"_sym = scheme_intern_symbol(\""stype"\");")
+      (~ "s = scheme_intern_symbol(\""stype"\");")
+      (cmake-object "t" ctype "s"
         (list "(Scheme_Object*)(void*)(&ffi_type_"ftype")")
         (list "(Scheme_Object*)FOREIGN_"cname))
       (~ "scheme_add_global(\"_"stype"\", (Scheme_Object*)t, menv);")):}
diff --git a/src/mzscheme/gc2/mem_account.c b/src/mzscheme/gc2/mem_account.c
index c6c6208fbd..55c611894e 100644
--- a/src/mzscheme/gc2/mem_account.c
+++ b/src/mzscheme/gc2/mem_account.c
@@ -214,7 +214,6 @@ inline static void clean_up_owner_table(NewGC *gc)
 inline static unsigned long custodian_usage(NewGC*gc, void *custodian)
 {
   OTEntry **owner_table = gc->owner_table;
-  const int table_size = gc->owner_table_size;
   unsigned long retval = 0;
   int i;
 
@@ -225,9 +224,13 @@ inline static unsigned long custodian_usage(NewGC*gc, void *custodian)
     custodian = gc->park[0]; 
     gc->park[0] = NULL;
   }
-  for(i = 1; i < table_size; i++)
-    if(owner_table[i] && custodian_member_owner_set(gc, custodian, i)) 
-      retval += owner_table[i]->memory_use;
+
+  i = custodian_to_owner_set(gc, (Scheme_Custodian *)custodian);
+  if (owner_table[i])
+    retval = owner_table[i]->memory_use;
+  else
+    retval = 0;
+
   return gcWORDS_TO_BYTES(retval);
 }
 
@@ -416,7 +419,7 @@ static void BTC_do_accounting(NewGC *gc)
   OTEntry **owner_table = gc->owner_table;
 
   if(gc->really_doing_accounting) {
-    Scheme_Custodian *cur = owner_table[current_owner(gc, NULL)]->originator;
+    Scheme_Custodian *cur = owner_table[current_owner(gc, NULL)]->originator, *last, *parent;
     Scheme_Custodian_Reference *box = cur->global_next;
     int i;
 
@@ -429,13 +432,14 @@ static void BTC_do_accounting(NewGC *gc)
     for(i = 1; i < table_size; i++)
       if(owner_table[i])
         owner_table[i]->memory_use = 0;
-
+    
     /* start with root: */
     while (cur->parent && SCHEME_PTR1_VAL(cur->parent)) {
       cur = SCHEME_PTR1_VAL(cur->parent);
     }
 
     /* walk forward for the order we want (blame parents instead of children) */
+    last = cur;
     while(cur) {
       int owner = custodian_to_owner_set(gc, cur);
 
@@ -447,9 +451,25 @@ static void BTC_do_accounting(NewGC *gc)
       GCDEBUG((DEBUGOUTF, "Propagating accounting marks\n"));
       propagate_accounting_marks(gc);
 
+      last = cur;
       box = cur->global_next; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
     }
 
+    /* walk backward folding totals int parent */
+    cur = last;
+    while (cur) {
+      int owner = custodian_to_owner_set(gc, cur);
+      
+      box = cur->parent; parent = box ? SCHEME_PTR1_VAL(box) : NULL;
+      if (parent) {
+        int powner = custodian_to_owner_set(gc, parent);
+
+        owner_table[powner]->memory_use += owner_table[owner]->memory_use;
+      }
+
+      box = cur->global_prev; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
+    }
+
     gc->in_unsafe_allocation_mode = 0;
     gc->doing_memory_accounting = 0;
     gc->old_btc_mark = gc->new_btc_mark;