diff --git a/collects/scheme/private/list.ss b/collects/scheme/private/list.ss
index 07305f74b5..383e1426b6 100644
--- a/collects/scheme/private/list.ss
+++ b/collects/scheme/private/list.ss
@@ -151,12 +151,38 @@
         (list last)
         (cons (f (car l)) (loop (cdr l))))))
 
+  (define (check-fold name proc init l more)
+    (unless (procedure? proc)
+      (apply raise-type-error name "procedure" 0 proc init l more))
+    (unless (list? l)
+      (apply raise-type-error name "list" 2 proc init l more))
+    (if (null? more)
+        (unless (procedure-arity-includes? proc 2)
+          (raise-mismatch-error name "arity mismatch, does not accept 1 argument: " proc))
+        (let ([len (length l)])
+          (let loop ([more more][n 3])
+            (unless (null? more)
+              (unless (list? (car more))
+                (apply raise-type-error name "list" n proc init l more))
+              (unless (= len (length (car more)))
+                (raise-mismatch-error name 
+                                      "given list does not have the same size as the first list: "
+                                      (car more)))
+              (loop (cdr more) (add1 n))))
+          (unless (procedure-arity-includes? proc (+ 2 (length more)))
+            (raise-mismatch-error name 
+                                  (format "arity mismatch, does not accept ~a arguments: " 
+                                          (add1 (length more)))
+                                  proc)))))
+
   (define foldl
     (case-lambda
       [(f init l)
+       (check-fold 'foldl f init l null)
        (let loop ([init init] [l l])
          (if (null? l) init (loop (f (car l) init) (cdr l))))]
       [(f init l . ls)
+       (check-fold 'foldl f init l ls)
        (let loop ([init init] [ls (cons l ls)])
          (cond [(andmap pair? ls)
                 (loop (apply f (mapadd car ls init)) (map cdr ls))]
@@ -167,11 +193,13 @@
   (define foldr
     (case-lambda
       [(f init l)
+       (check-fold 'foldr f init l null)
        (let loop ([init init] [l l])
          (if (null? l)
            init
            (f (car l) (loop init (cdr l)))))]
       [(f init l . ls)
+       (check-fold 'foldr f init l ls)
        (let loop ([ls (cons l ls)])
          (cond [(andmap pair? ls)
                 (apply f (mapadd car ls (loop (map cdr ls))))]
diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss
index cf6d65578c..891bdf4348 100644
--- a/collects/tests/mzscheme/list.ss
+++ b/collects/tests/mzscheme/list.ss
@@ -21,6 +21,23 @@
 (arity-test foldl 3 -1)
 (arity-test foldr 3 -1)
 
+(err/rt-test (foldl 'list 0 10))
+(err/rt-test (foldl list 0 10))
+(err/rt-test (foldl add1 0 '()))
+(err/rt-test (foldl cons 0 '() '()))
+(err/rt-test (foldl list 0 '() 10))
+(err/rt-test (foldl list 0 '() '() 10))
+(err/rt-test (let/ec k (foldl k 0 '(1 2) '(1 2 3))))
+(err/rt-test (let/ec k (foldl k 0 '(1 2) '(1 2) '(1 2 3))))
+(err/rt-test (foldr 'list 0 10))
+(err/rt-test (foldr list 0 10))
+(err/rt-test (foldr add1 0 '()))
+(err/rt-test (foldr cons 0 '() '()))
+(err/rt-test (foldr list 0 '() 10))
+(err/rt-test (foldr list 0 '() '() 10))
+(err/rt-test (let/ec k (foldr k 0 '(1 2) '(1 2 3))))
+(err/rt-test (let/ec k (foldr k 0 '(1 2) '(1 2) '(1 2 3))))
+
 (test '(0 1 2) memf add1 '(0 1 2))
 (test '(2 (c 17)) memf number? '((a 1) (0 x) (1 w) 2 (c 17)))
 (test '("ok" (2 .7) c) memf string? '((a 0) (0 a) (1 w) "ok" (2 .7) c))