diff --git a/collects/tests/typed-scheme/succeed/kw.rkt b/collects/tests/typed-scheme/succeed/kw.rkt
index 0d95c87c..a7a4ec81 100644
--- a/collects/tests/typed-scheme/succeed/kw.rkt
+++ b/collects/tests/typed-scheme/succeed/kw.rkt
@@ -4,3 +4,11 @@
   (open-input-file "foo" #:mode 'binary)  
   (open-input-file "foo" #:mode 'text)
   (open-input-file "foo"))
+
+((inst sort Real Real) (list 1 2 3) >)
+
+((inst sort Real Real) (list 1 2 3) #:key (λ: ([x : Real]) (/ 1 x)) >)
+
+((inst sort Real String) (list 1 2 3) #:key number->string string<?)
+
+((inst sort Real String) (list 1 2 3) #:key number->string string<? #:cache-keys? #t)
diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt
index 502bcbd9..1a92f30f 100644
--- a/collects/typed-scheme/private/base-env.rkt
+++ b/collects/typed-scheme/private/base-env.rkt
@@ -630,7 +630,13 @@
 
 [list->string ((-lst -Char) . -> . -String)]
 [string->list (-String . -> . (-lst -Char))]
-[sort (-poly (a) ((-lst a) (a a . -> . B) . -> . (-lst a)))]
+[sort (-poly (a b) (cl->* ((-lst a) (a a . -> . B)
+                          #:cache-keys? B #f
+                          . ->key . (-lst a))
+                         ((-lst a) (b b . -> . B)
+                          #:key (a . -> . b) #t
+                          #:cache-keys? B #f
+                          . ->key . (-lst a))))]
 [find-system-path (Sym . -> . -Path)]
 
 [object-name (Univ . -> . Univ)]
diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt
index 44e9d45a..8d9e9bb9 100644
--- a/collects/typed-scheme/typecheck/tc-app.rkt
+++ b/collects/typed-scheme/typecheck/tc-app.rkt
@@ -78,9 +78,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Keywords
 
-(define (tc-keywords form arities kws kw-args pos-args expected)
-  (match arities
-    [(list (arr: dom rng rest #f ktys))
+(define (tc-keywords/internal arity kws kw-args error?)
+  (match arity
+    [(arr: dom rng rest #f ktys)
      ;; assumes that everything is in sorted order
      (let loop ([actual-kws kws]
                 [actuals (map tc-expr/t (syntax->list kw-args))]
@@ -89,28 +89,59 @@
          [('() '())
           (void)]
          [(_ '())
-          (tc-error/expr #:return (ret (Un))
-                         "Unexpected keyword argument ~a" (car actual-kws))]
+          (if error? 
+              (tc-error/expr #:return (ret (Un))
+                             "Unexpected keyword argument ~a" (car actual-kws))
+              #f)]
          [('() (cons fst rst))
           (match fst
             [(Keyword: k _ #t)
-             (tc-error/expr #:return (ret (Un))
-                            "Missing keyword argument ~a" k)]
+             (if error?
+                 (tc-error/expr #:return (ret (Un))
+                                "Missing keyword argument ~a" k)
+                 #f)]
             [_ (loop actual-kws actuals rst)])]
          [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest))
-          (cond [(eq? k k*) ;; we have a match
-                 (unless (subtype (car actuals) t)
-                   (tc-error/delayed
-                    "Wrong function argument type, expected ~a, got ~a for keyword argument ~a"
-                    t (car actuals) k))
-                 (loop kws-rest (cdr actuals) form-rest)]
+          (cond [(eq? k k*) ;; we have a match                 
+                 (if (subtype (car actuals) t)
+                     ;; success
+                     (loop kws-rest (cdr actuals) form-rest)
+                     ;; failure
+                     (and error?
+                          (tc-error/delayed
+                           "Wrong function argument type, expected ~a, got ~a for keyword argument ~a"
+                           t (car actuals) k)
+                          (loop kws-rest (cdr actuals) form-rest)))]
                 [req? ;; this keyword argument was required
-                 (tc-error/delayed "Missing keyword argument ~a" k*)
-                 (loop kws-rest (cdr actuals) form-rest)]
+                 (if error? 
+                     (begin (tc-error/delayed "Missing keyword argument ~a" k*)
+                            (loop kws-rest (cdr actuals) form-rest))
+                     #f)]
                 [else ;; otherwise, ignore this formal param, and continue
-                 (loop actual-kws actuals form-rest)])]))
-     (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function (list (make-arr* dom rng #:rest rest)))) (map tc-expr (syntax->list pos-args)) expected)]
-    [_ (int-err "case-lambda w/ keywords not supported")]))
+                 (loop actual-kws actuals form-rest)])]))]))
+
+(define (tc-keywords form arities kws kw-args pos-args expected)
+  (match arities
+    [(list (and a (arr: dom rng rest #f ktys))) 
+     (tc-keywords/internal a kws kw-args #t)
+     (tc/funapp (car (syntax-e form)) kw-args
+                (ret (make-Function (list (make-arr* dom rng #:rest rest))))
+                (map tc-expr (syntax->list pos-args)) expected)]
+    [(list (and a (arr: doms rngs rests (and drests #f) ktyss)) ...)
+     (let ([new-arities 
+            (for/list ([a (in-list arities)]
+                       ;; find all the arities where the keywords match
+                       #:when (tc-keywords/internal a kws kw-args #f))
+              (match a
+                [(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))])
+       (if (null? new-arities)
+           (tc-error/expr 
+            #:return (or expected (ret (Un)))
+            (string-append "No function domains matched in function application:\n"
+                           (domain-mismatches arities doms rests drests rngs (map tc-expr (syntax->list pos-args)) #f #f)))
+         (tc/funapp (car (syntax-e form)) kw-args
+                    (ret (make-Function new-arities))
+                    (map tc-expr (syntax->list pos-args)) expected)))]))
 
 (define (type->list t)
   (match t